--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- A common interface to a collection of useful concurrency
+-- abstractions.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent
+ ( module Control.Concurrent.Chan
+ , module Control.Concurrent.CVar
+ , module Control.Concurrent.MVar
+ , module Control.Concurrent.QSem
+ , module Control.Concurrent.QSemN
+ , module Control.Concurrent.SampleVar
+
+#ifdef __HUGS__
+ , forkIO -- :: IO () -> IO ()
+#elif defined(__GLASGOW_HASKELL__)
+ , ThreadId
+
+ -- Forking and suchlike
+ , myThreadId -- :: IO ThreadId
+ , killThread -- :: ThreadId -> IO ()
+ , throwTo -- :: ThreadId -> Exception -> IO ()
+#endif
+ , par -- :: a -> b -> b
+ , seq -- :: a -> b -> b
+#ifdef __GLASGOW_HASKELL__
+ , fork -- :: a -> b -> b
+#endif
+ , yield -- :: IO ()
+
+#ifdef __GLASGOW_HASKELL__
+ , threadDelay -- :: Int -> IO ()
+ , threadWaitRead -- :: Int -> IO ()
+ , threadWaitWrite -- :: Int -> IO ()
+#endif
+
+ -- merging of streams
+ , mergeIO -- :: [a] -> [a] -> IO [a]
+ , nmergeIO -- :: [[a]] -> IO [a]
+ ) where
+
+import Prelude
+
+import Control.Exception as Exception
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc
+import GHC.TopHandler ( reportStackOverflow, reportError )
+import GHC.IOBase ( IO(..) )
+import GHC.IOBase ( unsafePerformIO , unsafeInterleaveIO )
+import GHC.Base ( fork# )
+import GHC.Prim ( Addr#, unsafeCoerce# )
+#endif
+
+#ifdef __HUGS__
+import IOExts ( unsafeInterleaveIO, unsafePerformIO )
+import ConcBase
+#endif
+
+import Control.Concurrent.MVar
+import Control.Concurrent.CVar
+import Control.Concurrent.Chan
+import Control.Concurrent.QSem
+import Control.Concurrent.QSemN
+import Control.Concurrent.SampleVar
+
+#ifdef __GLASGOW_HASKELL__
+infixr 0 `fork`
+#endif
+
+-- Thread Ids, specifically the instances of Eq and Ord for these things.
+-- The ThreadId type itself is defined in std/PrelConc.lhs.
+
+-- Rather than define a new primitve, we use a little helper function
+-- cmp_thread in the RTS.
+
+#ifdef __GLASGOW_HASKELL__
+foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
+-- Returns -1, 0, 1
+
+cmpThread :: ThreadId -> ThreadId -> Ordering
+cmpThread (ThreadId t1) (ThreadId t2) =
+ case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of
+ -1 -> LT
+ 0 -> EQ
+ _ -> GT -- must be 1
+
+instance Eq ThreadId where
+ t1 == t2 =
+ case t1 `cmpThread` t2 of
+ EQ -> True
+ _ -> False
+
+instance Ord ThreadId where
+ compare = cmpThread
+
+forkIO :: IO () -> IO ThreadId
+forkIO action = IO $ \ s ->
+ case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
+ where
+ action_plus = Exception.catch action childHandler
+
+childHandler :: Exception -> IO ()
+childHandler err = Exception.catch (real_handler err) childHandler
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+ case ex of
+ -- ignore thread GC and killThread exceptions:
+ BlockedOnDeadMVar -> return ()
+ AsyncException ThreadKilled -> return ()
+
+ -- report all others:
+ AsyncException StackOverflow -> reportStackOverflow False
+ ErrorCall s -> reportError False s
+ other -> reportError False (showsPrec 0 other "\n")
+
+{-# INLINE fork #-}
+fork :: a -> b -> b
+fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
+
+#endif /* __GLASGOW_HASKELL__ */
+
+
+max_buff_size :: Int
+max_buff_size = 1
+
+mergeIO :: [a] -> [a] -> IO [a]
+nmergeIO :: [[a]] -> IO [a]
+
+mergeIO ls rs
+ = newEmptyMVar >>= \ tail_node ->
+ newMVar tail_node >>= \ tail_list ->
+ newQSem max_buff_size >>= \ e ->
+ newMVar 2 >>= \ branches_running ->
+ let
+ buff = (tail_list,e)
+ in
+ forkIO (suckIO branches_running buff ls) >>
+ forkIO (suckIO branches_running buff rs) >>
+ takeMVar tail_node >>= \ val ->
+ signalQSem e >>
+ return val
+
+type Buffer a
+ = (MVar (MVar [a]), QSem)
+
+suckIO :: MVar Int -> Buffer a -> [a] -> IO ()
+
+suckIO branches_running buff@(tail_list,e) vs
+ = case vs of
+ [] -> takeMVar branches_running >>= \ val ->
+ if val == 1 then
+ takeMVar tail_list >>= \ node ->
+ putMVar node [] >>
+ putMVar tail_list node
+ else
+ putMVar branches_running (val-1)
+ (x:xs) ->
+ waitQSem e >>
+ takeMVar tail_list >>= \ node ->
+ newEmptyMVar >>= \ next_node ->
+ unsafeInterleaveIO (
+ takeMVar next_node >>= \ y ->
+ signalQSem e >>
+ return y) >>= \ next_node_val ->
+ putMVar node (x:next_node_val) >>
+ putMVar tail_list next_node >>
+ suckIO branches_running buff xs
+
+nmergeIO lss
+ = let
+ len = length lss
+ in
+ newEmptyMVar >>= \ tail_node ->
+ newMVar tail_node >>= \ tail_list ->
+ newQSem max_buff_size >>= \ e ->
+ newMVar len >>= \ branches_running ->
+ let
+ buff = (tail_list,e)
+ in
+ mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>
+ takeMVar tail_node >>= \ val ->
+ signalQSem e >>
+ return val
+ where
+ mapIO f xs = sequence (map f xs)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.CVar
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: CVar.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- Channel variables are one-element channels.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.CVar
+ ( -- abstract
+ CVar
+ , newCVar -- :: IO (CVar a)
+ , writeCVar -- :: CVar a -> a -> IO ()
+ , readCVar -- :: CVar a -> IO a
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+-- @MVars@ provide the basic mechanisms for synchronising access to a
+-- shared resource. @CVars@, or channel variables, provide an abstraction
+-- that guarantee that the producer is not allowed to run riot, but
+-- enforces the interleaved access to the channel variable,i.e., a
+-- producer is forced to wait up for a consumer to remove the previous
+-- value before it can deposit a new one in the @CVar@.
+
+data CVar a
+ = CVar (MVar a) -- prod -> cons
+ (MVar ()) -- cons -> prod
+
+newCVar :: IO (CVar a)
+newCVar
+ = newEmptyMVar >>= \ datum ->
+ newMVar () >>= \ ack ->
+ return (CVar datum ack)
+
+writeCVar :: CVar a -> a -> IO ()
+
+writeCVar (CVar datum ack) val
+ = takeMVar ack >>
+ putMVar datum val >>
+ return ()
+
+readCVar :: CVar a -> IO a
+readCVar (CVar datum ack)
+ = takeMVar datum >>= \ val ->
+ putMVar ack () >>
+ return val
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.Chan
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Chan.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Standard, unbounded channel abstraction.
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.Chan
+ ( Chan -- abstract
+
+ -- creator
+ , newChan -- :: IO (Chan a)
+
+ -- operators
+ , writeChan -- :: Chan a -> a -> IO ()
+ , readChan -- :: Chan a -> IO a
+ , dupChan -- :: Chan a -> IO (Chan a)
+ , unGetChan -- :: Chan a -> a -> IO ()
+
+ , isEmptyChan -- :: Chan a -> IO Bool
+
+ -- stream interface
+ , getChanContents -- :: Chan a -> IO [a]
+ , writeList2Chan -- :: Chan a -> [a] -> IO ()
+
+ ) where
+
+import Prelude
+
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import Control.Concurrent.MVar
+
+-- A channel is represented by two @MVar@s keeping track of the two ends
+-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s
+-- are used to handle consumers trying to read from an empty channel.
+
+data Chan a
+ = Chan (MVar (Stream a))
+ (MVar (Stream a))
+
+type Stream a = MVar (ChItem a)
+
+data ChItem a = ChItem a (Stream a)
+
+-- See the Concurrent Haskell paper for a diagram explaining the
+-- how the different channel operations proceed.
+
+-- @newChan@ sets up the read and write end of a channel by initialising
+-- these two @MVar@s with an empty @MVar@.
+
+newChan :: IO (Chan a)
+newChan = do
+ hole <- newEmptyMVar
+ read <- newMVar hole
+ write <- newMVar hole
+ return (Chan read write)
+
+-- To put an element on a channel, a new hole at the write end is created.
+-- What was previously the empty @MVar@ at the back of the channel is then
+-- filled in with a new stream element holding the entered value and the
+-- new hole.
+
+writeChan :: Chan a -> a -> IO ()
+writeChan (Chan _read write) val = do
+ new_hole <- newEmptyMVar
+ modifyMVar_ write $ \old_hole -> do
+ putMVar old_hole (ChItem val new_hole)
+ return new_hole
+
+readChan :: Chan a -> IO a
+readChan (Chan read _write) = do
+ modifyMVar read $ \read_end -> do
+ (ChItem val new_read_end) <- readMVar read_end
+ -- Use readMVar here, not takeMVar,
+ -- else dupChan doesn't work
+ return (new_read_end, val)
+
+dupChan :: Chan a -> IO (Chan a)
+dupChan (Chan _read write) = do
+ hole <- readMVar write
+ new_read <- newMVar hole
+ return (Chan new_read write)
+
+unGetChan :: Chan a -> a -> IO ()
+unGetChan (Chan read _write) val = do
+ new_read_end <- newEmptyMVar
+ modifyMVar_ read $ \read_end -> do
+ putMVar new_read_end (ChItem val read_end)
+ return new_read_end
+
+isEmptyChan :: Chan a -> IO Bool
+isEmptyChan (Chan read write) = do
+ withMVar read $ \r -> do
+ w <- readMVar write
+ let eq = r == w
+ eq `seq` return eq
+
+-- Operators for interfacing with functional streams.
+
+getChanContents :: Chan a -> IO [a]
+getChanContents ch
+ = unsafeInterleaveIO (do
+ x <- readChan ch
+ xs <- getChanContents ch
+ return (x:xs)
+ )
+
+-------------
+writeList2Chan :: Chan a -> [a] -> IO ()
+writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.MVar
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: MVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- MVars: Synchronising variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.MVar
+ ( MVar -- abstract
+ , newEmptyMVar -- :: IO (MVar a)
+ , newMVar -- :: a -> IO (MVar a)
+ , takeMVar -- :: MVar a -> IO a
+ , putMVar -- :: MVar a -> a -> IO ()
+ , readMVar -- :: MVar a -> IO a
+ , swapMVar -- :: MVar a -> a -> IO a
+ , tryTakeMVar -- :: MVar a -> IO (Maybe a)
+ , tryPutMVar -- :: MVar a -> a -> IO Bool
+ , isEmptyMVar -- :: MVar a -> IO Bool
+ , withMVar -- :: MVar a -> (a -> IO b) -> IO b
+ , modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO ()
+ , modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+ ) where
+
+#ifdef __HUGS__
+import ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+ tryTakeMVar, tryPutMVar, isEmptyMVar,
+ readMVar, swapMVar,
+ )
+import Prelude hiding( catch )
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
+ tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer
+ )
+#endif
+
+import Control.Exception as Exception
+
+#ifdef __HUGS__
+-- This is as close as Hugs gets to providing throw
+throw :: Exception -> IO a
+throw = throwIO
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+readMVar :: MVar a -> IO a
+readMVar m =
+ block $ do
+ a <- takeMVar m
+ putMVar m a
+ return a
+
+swapMVar :: MVar a -> a -> IO a
+swapMVar mvar new = modifyMVar mvar (\old -> return (new,old))
+#endif
+
+-- put back the same value, return something
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io =
+ block $ do
+ a <- takeMVar m
+ b <- Exception.catch (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a
+ return b
+
+-- put back a new value, return ()
+modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
+modifyMVar_ m io =
+ block $ do
+ a <- takeMVar m
+ a' <- Exception.catch (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a'
+
+-- put back a new value, return something
+modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
+modifyMVar m io =
+ block $ do
+ a <- takeMVar m
+ (a',b) <- Exception.catch (unblock (io a))
+ (\e -> do putMVar m a; throw e)
+ putMVar m a'
+ return b
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.QSem
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: QSem.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- General semaphores
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSem
+ ( QSem, -- abstract
+ newQSem, -- :: Int -> IO QSem
+ waitQSem, -- :: QSem -> IO ()
+ signalQSem -- :: QSem -> IO ()
+ ) where
+
+import Control.Concurrent.MVar
+
+-- General semaphores are also implemented readily in terms of shared
+-- @MVar@s, only have to catch the case when the semaphore is tried
+-- waited on when it is empty (==0). Implement this in the same way as
+-- shared variables are implemented - maintaining a list of @MVar@s
+-- representing threads currently waiting. The counter is a shared
+-- variable, ensuring the mutual exclusion on its access.
+
+newtype QSem = QSem (MVar (Int, [MVar ()]))
+
+newQSem :: Int -> IO QSem
+newQSem init = do
+ sem <- newMVar (init,[])
+ return (QSem sem)
+
+waitQSem :: QSem -> IO ()
+waitQSem (QSem sem) = do
+ (avail,blocked) <- takeMVar sem -- gain ex. access
+ if avail > 0 then
+ putMVar sem (avail-1,[])
+ else do
+ block <- newEmptyMVar
+ {-
+ Stuff the reader at the back of the queue,
+ so as to preserve waiting order. A signalling
+ process then only have to pick the MVar at the
+ front of the blocked list.
+
+ The version of waitQSem given in the paper could
+ lead to starvation.
+ -}
+ putMVar sem (0, blocked++[block])
+ takeMVar block
+
+signalQSem :: QSem -> IO ()
+signalQSem (QSem sem) = do
+ (avail,blocked) <- takeMVar sem
+ case blocked of
+ [] -> putMVar sem (avail+1,[])
+
+ (block:blocked') -> do
+ putMVar sem (0,blocked')
+ putMVar block ()
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.QSemN
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: QSemN.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Quantity semaphores
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.QSemN
+ ( QSemN, -- abstract
+ newQSemN, -- :: Int -> IO QSemN
+ waitQSemN, -- :: QSemN -> Int -> IO ()
+ signalQSemN -- :: QSemN -> Int -> IO ()
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())]))
+
+newQSemN :: Int -> IO QSemN
+newQSemN init = do
+ sem <- newMVar (init,[])
+ return (QSemN sem)
+
+waitQSemN :: QSemN -> Int -> IO ()
+waitQSemN (QSemN sem) sz = do
+ (avail,blocked) <- takeMVar sem -- gain ex. access
+ if (avail - sz) >= 0 then
+ -- discharging 'sz' still leaves the semaphore
+ -- in an 'unblocked' state.
+ putMVar sem (avail-sz,[])
+ else do
+ block <- newEmptyMVar
+ putMVar sem (avail, blocked++[(sz,block)])
+ takeMVar block
+
+signalQSemN :: QSemN -> Int -> IO ()
+signalQSemN (QSemN sem) n = do
+ (avail,blocked) <- takeMVar sem
+ (avail',blocked') <- free (avail+n) blocked
+ putMVar sem (avail',blocked')
+ where
+ free avail [] = return (avail,[])
+ free avail ((req,block):blocked)
+ | avail >= req = do
+ putMVar block ()
+ free (avail-req) blocked
+ | otherwise = do
+ (avail',blocked') <- free avail blocked
+ return (avail',(req,block):blocked')
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Concurrent.SampleVar
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: SampleVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sample variables
+--
+-----------------------------------------------------------------------------
+
+module Control.Concurrent.SampleVar
+ (
+ SampleVar, -- :: type _ =
+
+ newEmptySampleVar, -- :: IO (SampleVar a)
+ newSampleVar, -- :: a -> IO (SampleVar a)
+ emptySampleVar, -- :: SampleVar a -> IO ()
+ readSampleVar, -- :: SampleVar a -> IO a
+ writeSampleVar -- :: SampleVar a -> a -> IO ()
+
+ ) where
+
+import Prelude
+
+import Control.Concurrent.MVar
+
+-- Sample variables are slightly different from a normal MVar:
+--
+-- * Reading an empty SampleVar causes the reader to block.
+-- (same as takeMVar on empty MVar)
+--
+-- * Reading a filled SampleVar empties it and returns value.
+-- (same as takeMVar)
+--
+-- * Writing to an empty SampleVar fills it with a value, and
+-- potentially, wakes up a blocked reader (same as for putMVar on
+-- empty MVar).
+--
+-- * Writing to a filled SampleVar overwrites the current value.
+-- (different from putMVar on full MVar.)
+
+type SampleVar a
+ = MVar (Int, -- 1 == full
+ -- 0 == empty
+ -- <0 no of readers blocked
+ MVar a)
+
+-- Initally, a SampleVar is empty/unfilled.
+
+newEmptySampleVar :: IO (SampleVar a)
+newEmptySampleVar = do
+ v <- newEmptyMVar
+ newMVar (0,v)
+
+newSampleVar :: a -> IO (SampleVar a)
+newSampleVar a = do
+ v <- newEmptyMVar
+ putMVar v a
+ newMVar (1,v)
+
+emptySampleVar :: SampleVar a -> IO ()
+emptySampleVar v = do
+ (readers, var) <- takeMVar v
+ if readers >= 0 then
+ putMVar v (0,var)
+ else
+ putMVar v (readers,var)
+
+--
+-- filled => make empty and grab sample
+-- not filled => try to grab value, empty when read val.
+--
+readSampleVar :: SampleVar a -> IO a
+readSampleVar svar = do
+ (readers,val) <- takeMVar svar
+ putMVar svar (readers-1,val)
+ takeMVar val
+
+--
+-- filled => overwrite
+-- not filled => fill, write val
+--
+writeSampleVar :: SampleVar a -> a -> IO ()
+writeSampleVar svar v = do
+ (readers,val) <- takeMVar svar
+ case readers of
+ 1 ->
+ swapMVar val v >>
+ putMVar svar (1,val)
+ _ ->
+ putMVar val v >>
+ putMVar svar (min 1 (readers+1), val)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Exception
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Exception.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- The External API for exceptions. The functions provided in this
+-- module allow catching of exceptions in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Control.Exception (
+
+ Exception(..), -- instance Eq, Ord, Show, Typeable
+ IOException, -- instance Eq, Ord, Show, Typeable
+ ArithException(..), -- instance Eq, Ord, Show, Typeable
+ ArrayException(..), -- instance Eq, Ord, Show, Typeable
+ AsyncException(..), -- instance Eq, Ord, Show, Typeable
+
+ try, -- :: IO a -> IO (Either Exception a)
+ tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a)
+
+ catch, -- :: IO a -> (Exception -> IO a) -> IO a
+ catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+
+ evaluate, -- :: a -> IO a
+
+ -- Exception predicates (for catchJust, tryJust)
+
+ ioErrors, -- :: Exception -> Maybe IOError
+ arithExceptions, -- :: Exception -> Maybe ArithException
+ errorCalls, -- :: Exception -> Maybe String
+ dynExceptions, -- :: Exception -> Maybe Dynamic
+ assertions, -- :: Exception -> Maybe String
+ asyncExceptions, -- :: Exception -> Maybe AsyncException
+ userErrors, -- :: Exception -> Maybe String
+
+ -- Throwing exceptions
+
+ throw, -- :: Exception -> a
+#ifndef __STGHUGS__
+ -- for now
+ throwTo, -- :: ThreadId -> Exception -> a
+#endif
+
+ -- Dynamic exceptions
+
+ throwDyn, -- :: Typeable ex => ex -> b
+ throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b
+ catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a
+
+ -- Async exception control
+
+ block, -- :: IO a -> IO a
+ unblock, -- :: IO a -> IO a
+
+ -- Assertions
+
+ -- for now
+ assert, -- :: Bool -> a -> a
+
+ -- Utilities
+
+ finally, -- :: IO a -> IO b -> IO b
+
+ bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO ()
+ bracket_, -- :: IO a -> IO b -> IO c -> IO ()
+
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import Prelude hiding (catch)
+import GHC.Prim ( assert )
+import GHC.Exception hiding (try, catch, bracket, bracket_)
+import GHC.Conc ( throwTo, ThreadId )
+import GHC.IOBase ( IO(..) )
+#endif
+
+#ifdef __HUGS__
+import Prelude hiding ( catch )
+import PrelPrim ( catchException
+ , Exception(..)
+ , throw
+ , ArithException(..)
+ , AsyncException(..)
+ , assert
+ )
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception")
+INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException")
+INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
+INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
+INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
+
+-----------------------------------------------------------------------------
+-- Catching exceptions
+
+-- PrelException defines 'catchException' for us.
+
+catch :: IO a -> (Exception -> IO a) -> IO a
+catch = catchException
+
+catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a
+catchJust p a handler = catch a handler'
+ where handler' e = case p e of
+ Nothing -> throw e
+ Just b -> handler b
+
+-----------------------------------------------------------------------------
+-- evaluate
+
+evaluate :: a -> IO a
+evaluate a = a `seq` return a
+
+-----------------------------------------------------------------------------
+-- 'try' and variations.
+
+try :: IO a -> IO (Either Exception a)
+try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e))
+
+tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a)
+tryJust p a = do
+ r <- try a
+ case r of
+ Right v -> return (Right v)
+ Left e -> case p e of
+ Nothing -> throw e
+ Just b -> return (Left b)
+
+-----------------------------------------------------------------------------
+-- Dynamic exception types. Since one of the possible kinds of exception
+-- is a dynamically typed value, we can effectively have polymorphic
+-- exceptions.
+
+-- throwDyn will raise any value as an exception, provided it is in the
+-- Typeable class (see Dynamic.lhs).
+
+-- catchDyn will catch any exception of a given type (determined by the
+-- handler function). Any raised exceptions that don't match are
+-- re-raised.
+
+throwDyn :: Typeable exception => exception -> b
+throwDyn exception = throw (DynException (toDyn exception))
+
+throwDynTo :: Typeable exception => ThreadId -> exception -> IO ()
+throwDynTo t exception = throwTo t (DynException (toDyn exception))
+
+catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a
+catchDyn m k = catchException m handle
+ where handle ex = case ex of
+ (DynException dyn) ->
+ case fromDynamic dyn of
+ Just exception -> k exception
+ Nothing -> throw ex
+ _ -> throw ex
+
+-----------------------------------------------------------------------------
+-- Exception Predicates
+
+ioErrors :: Exception -> Maybe IOError
+arithExceptions :: Exception -> Maybe ArithException
+errorCalls :: Exception -> Maybe String
+dynExceptions :: Exception -> Maybe Dynamic
+assertions :: Exception -> Maybe String
+asyncExceptions :: Exception -> Maybe AsyncException
+userErrors :: Exception -> Maybe String
+
+ioErrors e@(IOException _) = Just e
+ioErrors _ = Nothing
+
+arithExceptions (ArithException e) = Just e
+arithExceptions _ = Nothing
+
+errorCalls (ErrorCall e) = Just e
+errorCalls _ = Nothing
+
+assertions (AssertionFailed e) = Just e
+assertions _ = Nothing
+
+dynExceptions (DynException e) = Just e
+dynExceptions _ = Nothing
+
+asyncExceptions (AsyncException e) = Just e
+asyncExceptions _ = Nothing
+
+userErrors (UserError e) = Just e
+userErrors _ = Nothing
+
+-----------------------------------------------------------------------------
+-- Some Useful Functions
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after thing =
+ block (do
+ a <- before
+ r <- catch
+ (unblock (thing a))
+ (\e -> do { after a; throw e })
+ after a
+ return r
+ )
+
+-- finally is an instance of bracket, but it's quite common
+-- so we give the specialised version for efficiency.
+finally :: IO a -> IO b -> IO a
+a `finally` sequel =
+ block (do
+ r <- catch
+ (unblock a)
+ (\e -> do { sequel; throw e })
+ sequel
+ return r
+ )
+
+bracket_ :: IO a -> IO b -> IO c -> IO c
+bracket_ before after thing = bracket before (const after) (const thing)
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Monad.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad
+ ( MonadPlus ( -- class context: Monad
+ mzero -- :: (MonadPlus m) => m a
+ , mplus -- :: (MonadPlus m) => m a -> m a -> m a
+ )
+ , join -- :: (Monad m) => m (m a) -> m a
+ , guard -- :: (MonadPlus m) => Bool -> m ()
+ , when -- :: (Monad m) => Bool -> m () -> m ()
+ , unless -- :: (Monad m) => Bool -> m () -> m ()
+ , ap -- :: (Monad m) => m (a -> b) -> m a -> m b
+ , msum -- :: (MonadPlus m) => [m a] -> m a
+ , filterM -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+ , mapAndUnzipM -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+ , zipWithM -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+ , zipWithM_ -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+ , foldM -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+
+ , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b)
+ , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+ , liftM3 -- :: ...
+ , liftM4 -- :: ...
+ , liftM5 -- :: ...
+
+ , Monad((>>=), (>>), return, fail)
+ , Functor(fmap)
+
+ , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b]
+ , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m ()
+ , sequence -- :: (Monad m) => [m a] -> m [a]
+ , sequence_ -- :: (Monad m) => [m a] -> m ()
+ , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b
+ ) where
+
+import Data.Maybe
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.List
+import GHC.Base
+#endif
+
+infixr 1 =<<
+
+-- -----------------------------------------------------------------------------
+-- Prelude monad functions
+
+{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+sequence :: Monad m => [m a] -> m [a]
+{-# INLINE sequence #-}
+sequence ms = foldr k (return []) ms
+ where
+ k m m' = do { x <- m; xs <- m'; return (x:xs) }
+
+sequence_ :: Monad m => [m a] -> m ()
+{-# INLINE sequence_ #-}
+sequence_ ms = foldr (>>) (return ()) ms
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+{-# INLINE mapM #-}
+mapM f as = sequence (map f as)
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+{-# INLINE mapM_ #-}
+mapM_ f as = sequence_ (map f as)
+
+-- -----------------------------------------------------------------------------
+-- Monadic classes: MonadPlus
+
+class Monad m => MonadPlus m where
+ mzero :: m a
+ mplus :: m a -> m a -> m a
+
+instance MonadPlus [] where
+ mzero = []
+ mplus = (++)
+
+instance MonadPlus Maybe where
+ mzero = Nothing
+
+ Nothing `mplus` ys = ys
+ xs `mplus` _ys = xs
+
+-- -----------------------------------------------------------------------------
+-- Functions mandated by the Prelude
+
+guard :: (MonadPlus m) => Bool -> m ()
+guard True = return ()
+guard False = mzero
+
+-- This subsumes the list-based filter function.
+
+filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
+filterM _ [] = return []
+filterM p (x:xs) = do
+ flg <- p x
+ ys <- filterM p xs
+ return (if flg then x:ys else ys)
+
+-- This subsumes the list-based concat function.
+
+msum :: MonadPlus m => [m a] -> m a
+{-# INLINE msum #-}
+msum = foldr mplus mzero
+
+-- -----------------------------------------------------------------------------
+-- Other monad functions
+
+join :: (Monad m) => m (m a) -> m a
+join x = x >>= id
+
+mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip
+
+zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys = sequence (zipWith f xs ys)
+
+zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+zipWithM_ f xs ys = sequence_ (zipWith f xs ys)
+
+foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM _ a [] = return a
+foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs
+
+unless :: (Monad m) => Bool -> m () -> m ()
+unless p s = if p then return () else s
+
+when :: (Monad m) => Bool -> m () -> m ()
+when p s = if p then s else return ()
+
+ap :: (Monad m) => m (a -> b) -> m a -> m b
+ap = liftM2 id
+
+liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
+liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
+liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
+liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
+liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
+
+liftM f m1 = do { x1 <- m1; return (f x1) }
+liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
+liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Cont
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Cont.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Continuation monads.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Cont (
+ MonadCont(..),
+ Cont(..),
+ runCont,
+ mapCont,
+ withCont,
+ ContT(..),
+ runContT,
+ mapContT,
+ withContT,
+ module Control.Monad,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.RWS
+
+class (Monad m) => MonadCont m where
+ callCC :: ((a -> m b) -> m a) -> m a
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable continuation monad
+
+newtype Cont r a = Cont { runCont :: (a -> r) -> r }
+
+instance Functor (Cont r) where
+ fmap f m = Cont $ \c -> runCont m (c . f)
+
+instance Monad (Cont r) where
+ return a = Cont ($ a)
+ m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c
+
+instance MonadCont (Cont r) where
+ callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c
+
+mapCont :: (r -> r) -> Cont r a -> Cont r a
+mapCont f m = Cont $ f . runCont m
+
+withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
+withCont f m = Cont $ runCont m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable continuation monad, with an inner monad
+
+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
+
+instance (Monad m) => Functor (ContT r m) where
+ fmap f m = ContT $ \c -> runContT m (c . f)
+
+instance (Monad m) => Monad (ContT r m) where
+ return a = ContT ($ a)
+ m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)
+
+instance (Monad m) => MonadCont (ContT r m) where
+ callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c
+
+instance MonadTrans (ContT r) where
+ lift m = ContT (m >>=)
+
+instance (MonadIO m) => MonadIO (ContT r m) where
+ liftIO = lift . liftIO
+
+instance (MonadReader r' m) => MonadReader r' (ContT r m) where
+ ask = lift ask
+ local f m = ContT $ \c -> do
+ r <- ask
+ local f (runContT m (local (const r) . c))
+
+instance (MonadState s m) => MonadState s (ContT r m) where
+ get = lift get
+ put = lift . put
+
+-- -----------------------------------------------------------------------------
+-- MonadCont instances for other monad transformers
+
+instance (MonadCont m) => MonadCont (ReaderT r m) where
+ callCC f = ReaderT $ \r ->
+ callCC $ \c ->
+ runReaderT (f (\a -> ReaderT $ \_ -> c a)) r
+
+instance (MonadCont m) => MonadCont (StateT s m) where
+ callCC f = StateT $ \s ->
+ callCC $ \c ->
+ runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
+
+instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
+ callCC f = WriterT $
+ callCC $ \c ->
+ runWriterT (f (\a -> WriterT $ c (a, mempty)))
+
+instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where
+ callCC f = RWST $ \r s ->
+ callCC $ \c ->
+ runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s
+
+mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
+mapContT f m = ContT $ f . runContT m
+
+withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
+withContT f m = ContT $ runContT m . f
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Error
+-- Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de>, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (reqruires multi-param type classes)
+--
+-- $Id: Error.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Error monad.
+--
+-- Rendered by Michael Weber <michael.weber@post.rwth-aachen.de>,
+-- inspired by the Haskell Monad Template Library from
+-- \A[HREF="http://www.cse.ogi.edu/~andy"]{Andy Gill}}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Error (
+ Error(..),
+ MonadError(..),
+ ErrorT(..),
+ runErrorT,
+ mapErrorT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+import Control.Monad.RWS
+import Control.Monad.Cont
+
+import System.IO
+
+-- ---------------------------------------------------------------------------
+-- class MonadError
+--
+-- throws an exception inside the monad and thus interrupts
+-- normal execution order, until an error handler is reached}
+--
+-- catches an exception inside the monad (that was previously
+-- thrown by throwError
+
+class Error a where
+ noMsg :: a
+ strMsg :: String -> a
+
+ noMsg = strMsg ""
+ strMsg _ = noMsg
+
+instance Error [Char] where
+ noMsg = ""
+ strMsg = id
+
+instance Error IOError where
+ strMsg = userError
+
+class (Monad m) => MonadError e m | m -> e where
+ throwError :: e -> m a
+ catchError :: m a -> (e -> m a) -> m a
+
+instance MonadPlus IO where
+ mzero = ioError (userError "mzero")
+ m `mplus` n = m `catch` \_ -> n
+
+instance MonadError IOError IO where
+ throwError = ioError
+ catchError = catch
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable error monad
+
+instance Functor (Either e) where
+ fmap _ (Left l) = Left l
+ fmap f (Right r) = Right (f r)
+
+instance (Error e) => Monad (Either e) where
+ return = Right
+ Left l >>= _ = Left l
+ Right r >>= k = k r
+ fail msg = Left (strMsg msg)
+
+instance (Error e) => MonadPlus (Either e) where
+ mzero = Left noMsg
+ Left _ `mplus` n = n
+ m `mplus` _ = m
+
+instance (Error e) => MonadFix (Either e) where
+ mfix f = let
+ a = f $ case a of
+ Right r -> r
+ _ -> error "empty mfix argument"
+ in a
+
+instance (Error e) => MonadError e (Either e) where
+ throwError = Left
+ Left l `catchError` h = h l
+ Right r `catchError` _ = Right r
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable error monad, with an inner monad
+
+newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
+
+-- The ErrorT Monad structure is parameterized over two things:
+-- * e - The error type.
+-- * m - The inner monad.
+
+-- Here are some examples of use:
+--
+-- type ErrorWithIO e a = ErrorT e IO a
+-- ==> ErrorT (IO (Either e a))
+--
+-- type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
+-- ==> ErrorT (StateT s IO (Either e a))
+-- ==> ErrorT (StateT (s -> IO (Either e a,s)))
+--
+
+instance (Monad m) => Functor (ErrorT e m) where
+ fmap f m = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> return (Left l)
+ Right r -> return (Right (f r))
+
+instance (Monad m, Error e) => Monad (ErrorT e m) where
+ return a = ErrorT $ return (Right a)
+ m >>= k = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> return (Left l)
+ Right r -> runErrorT (k r)
+ fail msg = ErrorT $ return (Left (strMsg msg))
+
+instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
+ mzero = ErrorT $ return (Left noMsg)
+ m `mplus` n = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left _ -> runErrorT n
+ Right r -> return (Right r)
+
+instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
+ mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of
+ Right r -> r
+ _ -> error "empty mfix argument"
+
+instance (Monad m, Error e) => MonadError e (ErrorT e m) where
+ throwError l = ErrorT $ return (Left l)
+ m `catchError` h = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> runErrorT (h l)
+ Right r -> return (Right r)
+
+instance (Error e) => MonadTrans (ErrorT e) where
+ lift m = ErrorT $ do
+ a <- m
+ return (Right a)
+
+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
+ liftIO = lift . liftIO
+
+instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where
+ ask = lift ask
+ local f m = ErrorT $ local f (runErrorT m)
+
+instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where
+ tell = lift . tell
+ listen m = ErrorT $ do
+ (a, w) <- listen (runErrorT m)
+ return $ case a of
+ Left l -> Left l
+ Right r -> Right (r, w)
+ pass m = ErrorT $ pass $ do
+ a <- runErrorT m
+ return $ case a of
+ Left l -> (Left l, id)
+ Right (r, f) -> (Right r, f)
+
+instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where
+ get = lift get
+ put = lift . put
+
+instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where
+ callCC f = ErrorT $
+ callCC $ \c ->
+ runErrorT (f (\a -> ErrorT $ c (Right a)))
+
+mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b
+mapErrorT f m = ErrorT $ f (runErrorT m)
+
+-- ---------------------------------------------------------------------------
+-- MonadError instances for other monad transformers
+
+instance (MonadError e m) => MonadError e (ReaderT r m) where
+ throwError = lift . throwError
+ m `catchError` h = ReaderT $ \r -> runReaderT m r
+ `catchError` \e -> runReaderT (h e) r
+
+instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
+ throwError = lift . throwError
+ m `catchError` h = WriterT $ runWriterT m
+ `catchError` \e -> runWriterT (h e)
+
+instance (MonadError e m) => MonadError e (StateT s m) where
+ throwError = lift . throwError
+ m `catchError` h = StateT $ \s -> runStateT m s
+ `catchError` \e -> runStateT (h e) s
+
+instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where
+ throwError = lift . throwError
+ m `catchError` h = RWST $ \r s -> runRWST m r s
+ `catchError` \e -> runRWST (h e) r s
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Fix
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (reqruires multi-param type classes)
+--
+-- $Id: Fix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Fix monad.
+--
+-- Inspired by the paper:
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Fix (
+ MonadFix(
+ mfix -- :: (a -> m a) -> m a
+ ),
+ fix -- :: (a -> a) -> a
+ ) where
+
+import Prelude
+
+import System.IO
+import Control.Monad.ST
+
+
+fix :: (a -> a) -> a
+fix f = let x = f x in x
+
+class (Monad m) => MonadFix m where
+ mfix :: (a -> m a) -> m a
+
+-- Perhaps these should live beside (the ST & IO) definition.
+instance MonadFix IO where
+ mfix = fixIO
+
+instance MonadFix (ST s) where
+ mfix = fixST
+
+instance MonadFix Maybe where
+ mfix f = let
+ a = f $ case a of
+ Just x -> x
+ _ -> error "empty mfix argument"
+ in a
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Identity
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- $Id: Identity.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Identity monad.
+--
+-- Inspired by the paper:
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.Identity (
+ Identity(..),
+ runIdentity,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+
+-- ---------------------------------------------------------------------------
+-- Identity wrapper
+--
+-- Abstraction for wrapping up a object.
+-- If you have an monadic function, say:
+--
+-- example :: Int -> IdentityMonad Int
+-- example x = return (x*x)
+--
+-- you can "run" it, using
+--
+-- Main> runIdentity (example 42)
+-- 1764 :: Int
+
+newtype Identity a = Identity { runIdentity :: a }
+
+-- ---------------------------------------------------------------------------
+-- Identity instances for Functor and Monad
+
+instance Functor Identity where
+ fmap f m = Identity (f (runIdentity m))
+
+instance Monad Identity where
+ return a = Identity a
+ m >>= k = k (runIdentity m)
+
+instance MonadFix Identity where
+ mfix f = Identity (fix (runIdentity . f))
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.List
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes )
+--
+-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The List monad.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.List (
+ ListT(..),
+ runListT,
+ mapListT,
+ module Control.Monad,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Cont
+import Control.Monad.Error
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable list monad, with an inner monad
+
+newtype ListT m a = ListT { runListT :: m [a] }
+
+instance (Monad m) => Functor (ListT m) where
+ fmap f m = ListT $ do
+ a <- runListT m
+ return (map f a)
+
+instance (Monad m) => Monad (ListT m) where
+ return a = ListT $ return [a]
+ m >>= k = ListT $ do
+ a <- runListT m
+ b <- mapM (runListT . k) a
+ return (concat b)
+ fail _ = ListT $ return []
+
+instance (Monad m) => MonadPlus (ListT m) where
+ mzero = ListT $ return []
+ m `mplus` n = ListT $ do
+ a <- runListT m
+ b <- runListT n
+ return (a ++ b)
+
+instance MonadTrans ListT where
+ lift m = ListT $ do
+ a <- m
+ return [a]
+
+instance (MonadIO m) => MonadIO (ListT m) where
+ liftIO = lift . liftIO
+
+instance (MonadReader s m) => MonadReader s (ListT m) where
+ ask = lift ask
+ local f m = ListT $ local f (runListT m)
+
+instance (MonadState s m) => MonadState s (ListT m) where
+ get = lift get
+ put = lift . put
+
+instance (MonadCont m) => MonadCont (ListT m) where
+ callCC f = ListT $
+ callCC $ \c ->
+ runListT (f (\a -> ListT $ c [a]))
+
+instance (MonadError e m) => MonadError e (ListT m) where
+ throwError = lift . throwError
+ m `catchError` h = ListT $ runListT m
+ `catchError` \e -> runListT (h e)
+
+mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b
+mapListT f m = ListT $ f (runListT m)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Monoid
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes )
+--
+-- $Id: Monoid.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the Monoid class,and instances for list and functions
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Monoid (
+ Monoid(..)
+ ) where
+
+import Prelude
+
+-- ---------------------------------------------------------------------------
+-- The Monoid class
+
+class Monoid a where
+ mempty :: a
+ mappend :: a -> a -> a
+ mconcat :: [a] -> a
+
+-- Now the default for mconcat. For most types, this
+-- default will be used, but is included in the class definition so
+-- that optimized version of mconcat can be provided
+-- for specific types.
+
+ mconcat = foldr mappend mempty
+
+-- Monoid instances.
+
+instance Monoid [a] where
+ mempty = []
+ mappend = (++)
+
+instance Monoid (a -> a) where
+ mempty = id
+ mappend = (.)
+
+instance Monoid () where
+ -- Should it be strict?
+ mempty = ()
+ _ `mappend` _ = ()
+ mconcat _ = ()
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.RWS
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes,
+-- requires functional dependencies )
+--
+-- $Id: RWS.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the MonadRWS class.
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS (
+ RWS(..),
+ runRWS,
+ evalRWS,
+ execRWS,
+ mapRWS,
+ withRWS,
+ RWST(..),
+ runRWST,
+ evalRWST,
+ execRWST,
+ mapRWST,
+ withRWST,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ module Control.Monad.Reader,
+ module Control.Monad.Writer,
+ module Control.Monad.State,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Monoid
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.State
+
+
+newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
+
+instance Functor (RWS r w s) where
+ fmap f m = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ in (f a, s', w)
+
+instance (Monoid w) => Monad (RWS r w s) where
+ return a = RWS $ \_ s -> (a, s, mempty)
+ m >>= k = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ (b, s'', w') = runRWS (k a) r s'
+ in (b, s'', w `mappend` w')
+
+instance (Monoid w) => MonadFix (RWS r w s) where
+ mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
+
+instance (Monoid w) => MonadReader r (RWS r w s) where
+ ask = RWS $ \r s -> (r, s, mempty)
+ local f m = RWS $ \r s -> runRWS m (f r) s
+
+instance (Monoid w) => MonadWriter w (RWS r w s) where
+ tell w = RWS $ \_ s -> ((), s, w)
+ listen m = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ in ((a, w), s', w)
+ pass m = RWS $ \r s -> let
+ ((a, f), s', w) = runRWS m r s
+ in (a, s', f w)
+
+instance (Monoid w) => MonadState s (RWS r w s) where
+ get = RWS $ \_ s -> (s, s, mempty)
+ put s = RWS $ \_ _ -> ((), s, mempty)
+
+
+evalRWS :: RWS r w s a -> r -> s -> (a, w)
+evalRWS m r s = let
+ (a, _, w) = runRWS m r s
+ in (a, w)
+
+execRWS :: RWS r w s a -> r -> s -> (s, w)
+execRWS m r s = let
+ (_, s', w) = runRWS m r s
+ in (s', w)
+
+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
+mapRWS f m = RWS $ \r s -> f (runRWS m r s)
+
+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
+withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
+
+
+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
+
+instance (Monad m) => Functor (RWST r w s m) where
+ fmap f m = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ return (f a, s', w)
+
+instance (Monoid w, Monad m) => Monad (RWST r w s m) where
+ return a = RWST $ \_ s -> return (a, s, mempty)
+ m >>= k = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ (b, s'',w') <- runRWST (k a) r s'
+ return (b, s'', w `mappend` w')
+ fail msg = RWST $ \_ _ -> fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
+ mzero = RWST $ \_ _ -> mzero
+ m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
+
+instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
+ mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
+
+instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
+ ask = RWST $ \r s -> return (r, s, mempty)
+ local f m = RWST $ \r s -> runRWST m (f r) s
+
+instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
+ tell w = RWST $ \_ s -> return ((),s,w)
+ listen m = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ return ((a, w), s', w)
+ pass m = RWST $ \r s -> do
+ ((a, f), s', w) <- runRWST m r s
+ return (a, s', f w)
+
+instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
+ get = RWST $ \_ s -> return (s, s, mempty)
+ put s = RWST $ \_ _ -> return ((), s, mempty)
+
+instance (Monoid w) => MonadTrans (RWST r w s) where
+ lift m = RWST $ \_ s -> do
+ a <- m
+ return (a, s, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
+ liftIO = lift . liftIO
+
+
+evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
+evalRWST m r s = do
+ (a, _, w) <- runRWST m r s
+ return (a, w)
+
+execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
+execRWST m r s = do
+ (_, s', w) <- runRWST m r s
+ return (s', w)
+
+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
+mapRWST f m = RWST $ \r s -> f (runRWST m r s)
+
+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Reader
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes,
+-- requires functional dependencies )
+--
+-- $Id: Reader.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Declaration of the Monoid class,and instances for list and functions
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Reader (
+ MonadReader(..),
+ asks,
+ Reader(..),
+ runReader,
+ mapReader,
+ withReader,
+ ReaderT(..),
+ runReaderT,
+ mapReaderT,
+ withReaderT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+
+-- ----------------------------------------------------------------------------
+-- class MonadReader
+-- asks for the internal (non-mutable) state.
+
+class (Monad m) => MonadReader r m | m -> r where
+ ask :: m r
+ local :: (r -> r) -> m a -> m a
+
+-- This allows you to provide a projection function.
+
+asks :: (MonadReader r m) => (r -> a) -> m a
+asks f = do
+ r <- ask
+ return (f r)
+
+-- ----------------------------------------------------------------------------
+-- The partially applied function type is a simple reader monad
+
+instance Functor ((->) r) where
+ fmap = (.)
+
+instance Monad ((->) r) where
+ return = const
+ m >>= k = \r -> k (m r) r
+
+instance MonadFix ((->) r) where
+ mfix f = \r -> let a = f a r in a
+
+instance MonadReader r ((->) r) where
+ ask = id
+ local f m = m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable reader monad
+
+newtype Reader r a = Reader { runReader :: r -> a }
+
+instance Functor (Reader r) where
+ fmap f m = Reader $ \r -> f (runReader m r)
+
+instance Monad (Reader r) where
+ return a = Reader $ \_ -> a
+ m >>= k = Reader $ \r -> runReader (k (runReader m r)) r
+
+instance MonadFix (Reader r) where
+ mfix f = Reader $ \r -> let a = runReader (f a) r in a
+
+instance MonadReader r (Reader r) where
+ ask = Reader id
+ local f m = Reader $ runReader m . f
+
+mapReader :: (a -> b) -> Reader r a -> Reader r b
+mapReader f m = Reader $ f . runReader m
+
+-- This is a more general version of local.
+
+withReader :: (r' -> r) -> Reader r a -> Reader r' a
+withReader f m = Reader $ runReader m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable reader monad, with an inner monad
+
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+instance (Monad m) => Functor (ReaderT r m) where
+ fmap f m = ReaderT $ \r -> do
+ a <- runReaderT m r
+ return (f a)
+
+instance (Monad m) => Monad (ReaderT r m) where
+ return a = ReaderT $ \_ -> return a
+ m >>= k = ReaderT $ \r -> do
+ a <- runReaderT m r
+ runReaderT (k a) r
+ fail msg = ReaderT $ \_ -> fail msg
+
+instance (MonadPlus m) => MonadPlus (ReaderT r m) where
+ mzero = ReaderT $ \_ -> mzero
+ m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r
+
+instance (MonadFix m) => MonadFix (ReaderT r m) where
+ mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r
+
+instance (Monad m) => MonadReader r (ReaderT r m) where
+ ask = ReaderT return
+ local f m = ReaderT $ \r -> runReaderT m (f r)
+
+instance MonadTrans (ReaderT r) where
+ lift m = ReaderT $ \_ -> m
+
+instance (MonadIO m) => MonadIO (ReaderT r m) where
+ liftIO = lift . liftIO
+
+mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b
+mapReaderT f m = ReaderT $ f . runReaderT m
+
+withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a
+withReaderT f m = ReaderT $ runReaderT m . f
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.ST
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The State Transformer Monad, ST
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST
+ (
+ ST -- abstract, instance of Functor, Monad, Typeable.
+ , runST -- :: (forall s. ST s a) -> a
+ , fixST -- :: (a -> ST s a) -> ST s a
+ , unsafeInterleaveST -- :: ST s a -> ST s a
+
+ , unsafeIOToST -- :: IO a -> ST s a
+
+ , RealWorld -- abstract
+ , stToIO -- :: ST RealWorld a -> IO a
+ ) where
+
+import Prelude
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.ST
+import GHC.Prim ( unsafeCoerce#, RealWorld )
+import GHC.IOBase ( IO(..), stToIO )
+
+unsafeIOToST :: IO a -> ST s a
+unsafeIOToST (IO io) = ST $ \ s ->
+ case ((unsafeCoerce# io) s) of
+ (# new_s, a #) -> unsafeCoerce# (STret new_s a)
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Typeable instance
+
+sTTc :: TyCon
+sTTc = mkTyCon "ST"
+
+instance (Typeable a, Typeable b) => Typeable (ST a b) where
+ typeOf st = mkAppTy sTTc [typeOf ((undefined :: ST a b -> a) st),
+ typeOf ((undefined :: ST a b -> b) st)]
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.ST.Lazy
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Lazy.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- This module presents an identical interface to Control.Monad.ST,
+-- but the underlying implementation of the state thread is lazy.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST.Lazy (
+ ST,
+
+ runST,
+ unsafeInterleaveST,
+ fixST,
+
+ STRef.STRef,
+ newSTRef, readSTRef, writeSTRef,
+
+ STArray.STArray,
+ newSTArray, readSTArray, writeSTArray, boundsSTArray,
+ thawSTArray, freezeSTArray, unsafeFreezeSTArray,
+#ifdef __GLASGOW_HASKELL__
+-- no 'good' reason, just doesn't support it right now.
+ unsafeThawSTArray,
+#endif
+
+ ST.unsafeIOToST, ST.stToIO,
+
+ strictToLazyST, lazyToStrictST
+ ) where
+
+import Prelude
+
+import qualified Data.STRef as STRef
+import Data.Array
+
+#ifdef __GLASGOW_HASKELL__
+import qualified Control.Monad.ST as ST
+import qualified GHC.Arr as STArray
+import qualified GHC.ST
+import GHC.Base ( ($), ()(..) )
+import Control.Monad
+import Data.Ix
+import GHC.Prim
+#endif
+
+#ifdef __HUGS__
+import qualified ST
+import Monad
+import Ix
+import Array
+import PrelPrim ( unST
+ , mkST
+ , PrimMutableArray
+ , PrimArray
+ , primNewArray
+ , primReadArray
+ , primWriteArray
+ , primUnsafeFreezeArray
+ , primSizeMutableArray
+ , primSizeArray
+ , primIndexArray
+ )
+#endif
+
+
+#ifdef __GLASGOW_HASKELL__
+newtype ST s a = ST (State s -> (a, State s))
+data State s = S# (State# s)
+#endif
+
+#ifdef __HUGS__
+newtype ST s a = ST (s -> (a,s))
+#endif
+
+instance Functor (ST s) where
+ fmap f m = ST $ \ s ->
+ let
+ ST m_a = m
+ (r,new_s) = m_a s
+ in
+ (f r,new_s)
+
+instance Monad (ST s) where
+
+ return a = ST $ \ s -> (a,s)
+ m >> k = m >>= \ _ -> k
+ fail s = error s
+
+ (ST m) >>= k
+ = ST $ \ s ->
+ let
+ (r,new_s) = m s
+ ST k_a = k r
+ in
+ k_a new_s
+
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE runST #-}
+runST :: (forall s. ST s a) -> a
+runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r
+#endif
+
+#ifdef __HUGS__
+runST :: (__forall s. ST s a) -> a
+runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r
+ where realWorld = error "runST: entered the RealWorld"
+#endif
+
+fixST :: (a -> ST s a) -> ST s a
+fixST m = ST (\ s ->
+ let
+ ST m_r = m r
+ (r,s) = m_r s
+ in
+ (r,s))
+
+-- ---------------------------------------------------------------------------
+-- Variables
+
+newSTRef :: a -> ST s (STRef.STRef s a)
+readSTRef :: STRef.STRef s a -> ST s a
+writeSTRef :: STRef.STRef s a -> a -> ST s ()
+
+newSTRef = strictToLazyST . STRef.newSTRef
+readSTRef = strictToLazyST . STRef.readSTRef
+writeSTRef r a = strictToLazyST (STRef.writeSTRef r a)
+
+-- --------------------------------------------------------------------------
+-- Arrays
+
+newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt)
+readSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt
+writeSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s ()
+boundsSTArray :: Ix ix => STArray.STArray s ix elt -> (ix, ix)
+thawSTArray :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt)
+freezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
+unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt)
+
+#ifdef __GLASGOW_HASKELL__
+
+newSTArray ixs init = strictToLazyST (STArray.newSTArray ixs init)
+
+readSTArray arr ix = strictToLazyST (STArray.readSTArray arr ix)
+writeSTArray arr ix v = strictToLazyST (STArray.writeSTArray arr ix v)
+boundsSTArray arr = STArray.boundsSTArray arr
+thawSTArray arr = strictToLazyST (STArray.thawSTArray arr)
+freezeSTArray arr = strictToLazyST (STArray.freezeSTArray arr)
+unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr)
+unsafeThawSTArray arr = strictToLazyST (STArray.unsafeThawSTArray arr)
+#endif
+
+
+#ifdef __HUGS__
+newSTArray ixs elt = do
+ { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt)
+ ; return (STArray ixs arr)
+ }
+
+boundsSTArray (STArray ixs arr) = ixs
+readSTArray (STArray ixs arr) ix
+ = strictToLazyST (primReadArray arr (index ixs ix))
+writeSTArray (STArray ixs arr) ix elt
+ = strictToLazyST (primWriteArray arr (index ixs ix) elt)
+freezeSTArray (STArray ixs arr) = do
+ { arr' <- strictToLazyST (primFreezeArray arr)
+ ; return (Array ixs arr')
+ }
+
+unsafeFreezeSTArray (STArray ixs arr) = do
+ { arr' <- strictToLazyST (primUnsafeFreezeArray arr)
+ ; return (Array ixs arr')
+ }
+
+thawSTArray (Array ixs arr) = do
+ { arr' <- strictToLazyST (primThawArray arr)
+ ; return (STArray ixs arr')
+ }
+
+primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a)
+primFreezeArray arr = do
+ { let n = primSizeMutableArray arr
+ ; arr' <- primNewArray n arrEleBottom
+ ; mapM_ (copy arr arr') [0..n-1]
+ ; primUnsafeFreezeArray arr'
+ }
+ where
+ copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x }
+ arrEleBottom = error "primFreezeArray: panic"
+
+primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a)
+primThawArray arr = do
+ { let n = primSizeArray arr
+ ; arr' <- primNewArray n arrEleBottom
+ ; mapM_ (copy arr arr') [0..n-1]
+ ; return arr'
+ }
+ where
+ copy arr arr' i = primWriteArray arr' i (primIndexArray arr i)
+ arrEleBottom = error "primFreezeArray: panic"
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Strict <--> Lazy
+
+#ifdef __GLASGOW_HASKELL__
+strictToLazyST :: ST.ST s a -> ST s a
+strictToLazyST m = ST $ \s ->
+ let
+ pr = case s of { S# s# -> GHC.ST.liftST m s# }
+ r = case pr of { GHC.ST.STret _ v -> v }
+ s' = case pr of { GHC.ST.STret s2# _ -> S# s2# }
+ in
+ (r, s')
+
+lazyToStrictST :: ST s a -> ST.ST s a
+lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
+ case (m (S# s)) of (a, S# s') -> (# s', a #)
+#endif
+
+#ifdef __HUGS__
+strictToLazyST :: ST.ST s a -> ST s a
+strictToLazyST m = ST $ \s ->
+ let
+ pr = unST m s
+ r = fst pr
+ s' = snd pr
+ in
+ (r, s')
+
+
+lazyToStrictST :: ST s a -> ST.ST s a
+lazyToStrictST (ST m) = mkST $ m
+#endif
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.ST.Strict
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Strict.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The strict ST monad (identical to Control.Monad.ST)
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.ST.Strict (
+ module Control.Monad.ST
+ ) where
+
+import Prelude
+import Control.Monad.ST
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.State
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes,
+-- requires functional dependencies )
+--
+-- $Id: State.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- State monads.
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.State (
+ MonadState(..),
+ modify,
+ gets,
+ State(..),
+ runState,
+ evalState,
+ execState,
+ mapState,
+ withState,
+ StateT(..),
+ runStateT,
+ evalStateT,
+ execStateT,
+ mapStateT,
+ withStateT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+import Control.Monad.Writer
+
+-- ---------------------------------------------------------------------------
+-- MonadState class
+--
+-- get: returns the state from the internals of the monad.
+-- put: changes (replaces) the state inside the monad.
+
+class (Monad m) => MonadState s m | m -> s where
+ get :: m s
+ put :: s -> m ()
+
+-- Monadic state transformer.
+--
+-- Maps an old state to a new state inside a state monad.
+-- The old state is thrown away.}
+--
+-- Main> :t modify ((+1) :: Int -> Int)
+-- modify (...) :: (MonadState Int a) => a ()
+--
+-- This says that modify (+1) acts over any
+-- Monad that is a member of the MonadState class,
+-- with an Int state.
+
+modify :: (MonadState s m) => (s -> s) -> m ()
+modify f = do
+ s <- get
+ put (f s)
+
+-- Get part of the state
+--
+-- gets specific component of the state,
+-- using a projection function supplied.
+
+gets :: (MonadState s m) => (s -> a) -> m a
+gets f = do
+ s <- get
+ return (f s)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable state monad
+
+newtype State s a = State { runState :: s -> (a, s) }
+
+-- The State Monad structure is paramterized over just the state.
+
+instance Functor (State s) where
+ fmap f m = State $ \s -> let
+ (a, s') = runState m s
+ in (f a, s')
+
+instance Monad (State s) where
+ return a = State $ \s -> (a, s)
+ m >>= k = State $ \s -> let
+ (a, s') = runState m s
+ in runState (k a) s'
+
+instance MonadFix (State s) where
+ mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s')
+
+instance MonadState s (State s) where
+ get = State $ \s -> (s, s)
+ put s = State $ \_ -> ((), s)
+
+
+evalState :: State s a -> s -> a
+evalState m s = fst (runState m s)
+
+execState :: State s a -> s -> s
+execState m s = snd (runState m s)
+
+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
+mapState f m = State $ f . runState m
+
+withState :: (s -> s) -> State s a -> State s a
+withState f m = State $ runState m . f
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable state monad, with an inner monad
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+--The StateT Monad structure is parameterized over two things:
+--
+-- * s - The state.
+-- * m - The inner monad.
+
+-- Here are some examples of use:
+
+-- (Parser from ParseLib with Hugs)
+-- type Parser a = StateT String [] a
+-- ==> StateT (String -> [(a,String)])
+-- For example, item can be written as:
+-- item = do (x:xs) <- get
+-- put xs
+-- return x
+
+-- type BoringState s a = StateT s Indentity a
+-- ==> StateT (s -> Identity (a,s))
+--
+-- type StateWithIO s a = StateT s IO a
+-- ==> StateT (s -> IO (a,s))
+--
+-- type StateWithErr s a = StateT s Maybe a
+-- ==> StateT (s -> Maybe (a,s))
+
+instance (Monad m) => Functor (StateT s m) where
+ fmap f m = StateT $ \s -> do
+ (x, s') <- runStateT m s
+ return (f x, s')
+
+instance (Monad m) => Monad (StateT s m) where
+ return a = StateT $ \s -> return (a, s)
+ m >>= k = StateT $ \s -> do
+ (a, s') <- runStateT m s
+ runStateT (k a) s'
+ fail str = StateT $ \_ -> fail str
+
+instance (MonadPlus m) => MonadPlus (StateT s m) where
+ mzero = StateT $ \_ -> mzero
+ m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
+
+instance (MonadFix m) => MonadFix (StateT s m) where
+ mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
+
+instance (Monad m) => MonadState s (StateT s m) where
+ get = StateT $ \s -> return (s, s)
+ put s = StateT $ \_ -> return ((), s)
+
+instance MonadTrans (StateT s) where
+ lift m = StateT $ \s -> do
+ a <- m
+ return (a, s)
+
+instance (MonadIO m) => MonadIO (StateT s m) where
+ liftIO = lift . liftIO
+
+instance (MonadReader r m) => MonadReader r (StateT s m) where
+ ask = lift ask
+ local f m = StateT $ \s -> local f (runStateT m s)
+
+instance (MonadWriter w m) => MonadWriter w (StateT s m) where
+ tell = lift . tell
+ listen m = StateT $ \s -> do
+ ((a, s'), w) <- listen (runStateT m s)
+ return ((a, w), s')
+ pass m = StateT $ \s -> pass $ do
+ ((a, f), s') <- runStateT m s
+ return ((a, s'), f)
+
+
+evalStateT :: (Monad m) => StateT s m a -> s -> m a
+evalStateT m s = do
+ (a, _) <- runStateT m s
+ return a
+
+execStateT :: (Monad m) => StateT s m a -> s -> m s
+execStateT m s = do
+ (_, s') <- runStateT m s
+ return s'
+
+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
+mapStateT f m = StateT $ f . runStateT m
+
+withStateT :: (s -> s) -> StateT s m a -> StateT s m a
+withStateT f m = StateT $ runStateT m . f
+
+-- ---------------------------------------------------------------------------
+-- MonadState instances for other monad transformers
+
+instance (MonadState s m) => MonadState s (ReaderT r m) where
+ get = lift get
+ put = lift . put
+
+instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
+ get = lift get
+ put = lift . put
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Trans
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- $Id: Trans.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The MonadTrans class.
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Trans (
+ MonadTrans(..),
+ MonadIO(..),
+ ) where
+
+import Prelude
+
+import System.IO
+
+-- ---------------------------------------------------------------------------
+-- MonadTrans class
+--
+-- Monad to facilitate stackable Monads.
+-- Provides a way of digging into an outer
+-- monad, giving access to (lifting) the inner monad.
+
+class MonadTrans t where
+ lift :: Monad m => m a -> t m a
+
+class (Monad m) => MonadIO m where
+ liftIO :: IO a -> m a
+
+instance MonadIO IO where
+ liftIO = id
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Monad.Writer
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable ( requires mulit-parameter type classes,
+-- requires functional dependencies )
+--
+-- $Id: Writer.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The MonadWriter class.
+--
+-- Inspired by the paper
+-- \em{Functional Programming with Overloading and
+-- Higher-Order Polymorphism},
+-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones},
+-- Advanced School of Functional Programming, 1995.}
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer (
+ MonadWriter(..),
+ listens,
+ censor,
+ Writer(..),
+ runWriter,
+ execWriter,
+ mapWriter,
+ WriterT(..),
+ runWriterT,
+ execWriterT,
+ mapWriterT,
+ module Control.Monad,
+ module Control.Monad.Monoid,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ ) where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.Monoid
+import Control.Monad.Fix
+import Control.Monad.Trans
+import Control.Monad.Reader
+
+-- ---------------------------------------------------------------------------
+-- MonadWriter class
+--
+-- tell is like tell on the MUD's it shouts to monad
+-- what you want to be heard. The monad carries this 'packet'
+-- upwards, merging it if needed (hence the Monoid requirement)}
+--
+-- listen listens to a monad acting, and returns what the monad "said".
+--
+-- pass lets you provide a writer transformer which changes internals of
+-- the written object.
+
+class (Monoid w, Monad m) => MonadWriter w m | m -> w where
+ tell :: w -> m ()
+ listen :: m a -> m (a, w)
+ pass :: m (a, w -> w) -> m a
+
+listens :: (MonadWriter w m) => (w -> w) -> m a -> m (a, w)
+listens f m = do
+ (a, w) <- listen m
+ return (a, f w)
+
+censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
+censor f m = pass $ do
+ a <- m
+ return (a, f)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad
+
+newtype Writer w a = Writer { runWriter :: (a, w) }
+
+
+instance Functor (Writer w) where
+ fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
+
+instance (Monoid w) => Monad (Writer w) where
+ return a = Writer (a, mempty)
+ m >>= k = Writer $ let
+ (a, w) = runWriter m
+ (b, w') = runWriter (k a)
+ in (b, w `mappend` w')
+
+instance (Monoid w) => MonadFix (Writer w) where
+ mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
+
+instance (Monoid w) => MonadWriter w (Writer w) where
+ tell w = Writer ((), w)
+ listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
+ pass m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
+
+
+execWriter :: Writer w a -> w
+execWriter m = snd (runWriter m)
+
+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
+mapWriter f m = Writer $ f (runWriter m)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad, with an inner monad
+
+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+
+
+instance (Monad m) => Functor (WriterT w m) where
+ fmap f m = WriterT $ do
+ (a, w) <- runWriterT m
+ return (f a, w)
+
+instance (Monoid w, Monad m) => Monad (WriterT w m) where
+ return a = WriterT $ return (a, mempty)
+ m >>= k = WriterT $ do
+ (a, w) <- runWriterT m
+ (b, w') <- runWriterT (k a)
+ return (b, w `mappend` w')
+ fail msg = WriterT $ fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
+ mzero = WriterT mzero
+ m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
+
+instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
+ mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
+
+instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
+ tell w = WriterT $ return ((), w)
+ listen m = WriterT $ do
+ (a, w) <- runWriterT m
+ return ((a, w), w)
+ pass m = WriterT $ do
+ ((a, f), w) <- runWriterT m
+ return (a, f w)
+
+instance (Monoid w) => MonadTrans (WriterT w) where
+ lift m = WriterT $ do
+ a <- m
+ return (a, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
+ liftIO = lift . liftIO
+
+instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
+ ask = lift ask
+ local f m = WriterT $ local f (runWriterT m)
+
+
+execWriterT :: Monad m => WriterT w m a -> m w
+execWriterT m = do
+ (_, w) <- runWriterT m
+ return w
+
+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
+mapWriterT f m = WriterT $ f (runWriterT m)
+
+-- ---------------------------------------------------------------------------
+-- MonadWriter instances for other monad transformers
+
+instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
+ tell = lift . tell
+ listen m = ReaderT $ \w -> listen (runReaderT m w)
+ pass m = ReaderT $ \w -> pass (runReaderT m w)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Parallel
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Parallel.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- Parallel Constructs
+--
+-----------------------------------------------------------------------------
+
+module Control.Parallel (
+ par, seq -- re-exported
+#if defined(__GRANSIM__)
+ , parGlobal, parLocal, parAt, parAtAbs, parAtRel, parAtForNow
+#endif
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Conc ( par )
+#endif
+
+#if defined(__GRANSIM__)
+import PrelBase
+import PrelErr ( parError )
+import PrelGHC ( parGlobal#, parLocal#, parAt#, parAtAbs#, parAtRel#, parAtForNow# )
+
+{-# INLINE parGlobal #-}
+{-# INLINE parLocal #-}
+{-# INLINE parAt #-}
+{-# INLINE parAtAbs #-}
+{-# INLINE parAtRel #-}
+{-# INLINE parAtForNow #-}
+parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b
+parLocal :: Int -> Int -> Int -> Int -> a -> b -> b
+parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c
+parAtAbs :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
+parAtRel :: Int -> Int -> Int -> Int -> Int -> a -> b -> b
+parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c
+
+parGlobal (I# w) (I# g) (I# s) (I# p) x y = case (parGlobal# x w g s p y) of { 0# -> parError; _ -> y }
+parLocal (I# w) (I# g) (I# s) (I# p) x y = case (parLocal# x w g s p y) of { 0# -> parError; _ -> y }
+
+parAt (I# w) (I# g) (I# s) (I# p) v x y = case (parAt# x v w g s p y) of { 0# -> parError; _ -> y }
+parAtAbs (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtAbs# x q w g s p y) of { 0# -> parError; _ -> y }
+parAtRel (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtRel# x q w g s p y) of { 0# -> parError; _ -> y }
+parAtForNow (I# w) (I# g) (I# s) (I# p) v x y = case (parAtForNow# x v w g s p y) of { 0# -> parError; _ -> y }
+
+#endif
+
+-- Maybe parIO and the like could be added here later.
+#ifndef __GLASGOW_HASKELL__
+-- For now, Hugs does not support par properly.
+par a b = b
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Control.Parallel.Strategies
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Parallel strategy combinators
+--
+-----------------------------------------------------------------------------
+
+{-
+Time-stamp: <Wed Mar 21 2001 00:45:34 Stardate: [-30]6360.15 hwloidl>
+$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+
+This module defines parallel strategy combinators
+
+ Phil Trinder, Hans-Wolfgang Loidl, Kevin Hammond et al.
+
+ Based on Version VII (1/5/96) `Strategies96' of type a -> ()
+
+Author: $Author: simonmar $
+Date: $Date: 2001/06/28 14:15:02 $
+Revision: $Revision: 1.1 $
+Source: $Source: /srv/cvs/cvs.haskell.org/fptools/libraries/base/Control/Parallel/Strategies.hs,v $
+State: $State: Exp $
+
+This module defines evaluation strategies for controlling the parallel
+evaluation of non-strict programs. They provide a clean separation between
+algorithmic and behavioural code.
+
+The functions described here, and their use is documented in
+
+"Algorithm + Strategy = Parallelism",
+P.W. Trinder, K. Hammond, H-W. Loidl, S.L. Peyton Jones
+In Journal of Functional Programming 8(1):23--60, January 1998.
+URL: http://www.cee.hw.ac.uk/~dsg/gph/papers/ps/strategies.ps.gz
+
+This module supports Haskell 1.2, Haskell 1.4 and Haskell98.
+The distinction is made based on the __HASKELL1__ CPP variable.
+Parts of the module could be rewritten using constructor classes.
+
+-----------------------------------------------------------------------------
+The history of the Strategies module:
+
+Changelog:
+$Log: Strategies.hs,v $
+Revision 1.1 2001/06/28 14:15:02 simonmar
+First cut of the Haskell Core Libraries
+=======================================
+
+NOTE: it's not meant to be a working snapshot. The code is just here
+to look at and so the NHC/Hugs guys can start playing around with it.
+
+There is no build system. For GHC, the libraries tree is intended to
+be grafted onto an existing fptools/ tree, and the Makefile in
+libraries/core is a quick hack for that setup. This won't work at the
+moment without the other changes needed in fptools/ghc, which I
+haven't committed because they'll cause breakage. However, with the
+changes required these sources build a working Prelude and libraries.
+
+The layout mostly follows the one we agreed on, with one or two minor
+changes; in particular the Data/Array layout probably isn't final
+(there are several choices here).
+
+The document is in libraries/core/doc as promised.
+
+The cbits stuff is just a copy of ghc/lib/std/cbits and has
+GHC-specific stuff in it. We should really separate the
+compiler-specific C support from any compiler-independent C support
+there might be.
+
+Don't pay too much attention to the portability or stability status
+indicated in the header of each source file at the moment - I haven't
+gone through to make sure they're all consistent and make sense.
+
+I'm using non-literate source outside of GHC/. Hope that's ok with
+everyone.
+
+We need to discuss how the build system is going to work...
+
+Revision 1.3 2001/03/22 03:51:12 hwloidl
+ -*- outline -*-
+Time-stamp: <Thu Mar 22 2001 03:50:16 Stardate: [-30]6365.79 hwloidl>
+
+This commit covers changes in GHC to get GUM (way=mp) and GUM/GdH (way=md)
+working. It is a merge of my working version of GUM, based on GHC 4.06,
+with GHC 4.11. Almost all changes are in the RTS (see below).
+
+GUM is reasonably stable, we used the 4.06 version in large-ish programs for
+recent papers. Couple of things I want to change, but nothing urgent.
+GUM/GdH has just been merged and needs more testing. Hope to do that in the
+next weeks. It works in our working build but needs tweaking to run.
+GranSim doesn't work yet (*sigh*). Most of the code should be in, but needs
+more debugging.
+
+ToDo: I still want to make the following minor modifications before the release
+- Better wrapper skript for parallel execution [ghc/compiler/main]
+- Update parallel docu: started on it but it's minimal [ghc/docs/users_guide]
+- Clean up [nofib/parallel]: it's a real mess right now (*sigh*)
+- Update visualisation tools (minor things only IIRC) [ghc/utils/parallel]
+- Add a Klingon-English glossary
+
+* RTS:
+
+Almost all changes are restricted to ghc/rts/parallel and should not
+interfere with the rest. I only comment on changes outside the parallel
+dir:
+
+- Several changes in Schedule.c (scheduling loop; createThreads etc);
+ should only affect parallel code
+- Added ghc/rts/hooks/ShutdownEachPEHook.c
+- ghc/rts/Linker.[ch]: GUM doesn't know about Stable Names (ifdefs)!!
+- StgMiscClosures.h: END_TSO_QUEUE etc now defined here (from StgMiscClosures.hc)
+ END_ECAF_LIST was missing a leading stg_
+- SchedAPI.h: taskStart now defined in here; it's only a wrapper around
+ scheduleThread now, but might use some init, shutdown later
+- RtsAPI.h: I have nuked the def of rts_evalNothing
+
+* Compiler:
+
+- ghc/compiler/main/DriverState.hs
+ added PVM-ish flags to the parallel way
+ added new ways for parallel ticky profiling and distributed exec
+
+- ghc/compiler/main/DriverPipeline.hs
+ added a fct run_phase_MoveBinary which is called with way=mp after linking;
+ it moves the bin file into a PVM dir and produces a wrapper script for
+ parallel execution
+ maybe cleaner to add a MoveBinary phase in DriverPhases.hs but this way
+ it's less intrusive and MoveBinary makes probably only sense for mp anyway
+
+* Nofib:
+
+- nofib/spectral/Makefile, nofib/real/Makefile, ghc/tests/programs/Makefile:
+ modified to skip some tests if HWL_NOFIB_HACK is set; only tmp to record
+ which test prgs cause problems in my working build right now
+
+Revision 1.2 2000/11/18 02:13:11 hwloidl
+Now provides explicit def of seq (rather than just re-exporting).
+Required by the current version of the compiler.
+
+Revision 1.1 2000/01/14 13:34:32 hwloidl
+Module for specifying (parallel) behavioural code.
+
+Revision 1.9 1997/10/01 00:27:19 hwloidl
+Type of par and seq changed to Done -> Done -> Done with Done = ()
+Works for Haskell 1.2 as well as Haskell 1.4 (checks the CPP variable
+__HASKELL1__ to distinguish setups).
+Fixed precedences for par and seq for Haskell 1.4 (stronger than using).
+New infix operators >| and >|| as aliases for par and seq as strategy
+combinators.
+
+Revision 1.8 1997/05/20 21:13:22 hwloidl
+Revised to use `demanding` and `sparking` (final JFP paper version)
+
+Revision 1.7 1997/04/02 21:26:21 hwloidl
+Minor changes in documentation, none in the code.
+
+
+revision 1.5
+Version VII.1; Strategies96; Type: a -> ()
+Minor changes to previous version.
+CPP flags now separate GUM from GranSim version.
+Infix declaration for `using` (important for e.g. quicksort where the old
+version puts parentheses in the wrong way).
+Moer instances for NFData and markStartegies (in GranSim setup only).
+
+revision 1.4
+Version VII; Strategies96; Type: a -> ()
+The type has changed again; with the old type it's not possible to describe
+all the strategies we want (for example seqPair r0 rnf which should not
+evaluate the first component of the pair at all). The () type acts as info
+that the strategy has been applied.
+The function `using` is used as inverse strategy application i.e.
+on top level we usually have something like res `using` strat where ...
+The markStrategy hack is included in this version: it attaches an Int value
+to the currently running strategy (this can be inherited by all sub-strats)
+It doesn't model the jumps between evaluating producer and consumer properly
+(for that something like cost centers would be necessary).
+
+revision 1.3
+Version VI (V-based); Strategies95; Type: a -> a
+Now uses library modules like FiniteMap with strategies in there.
+CPP flags for using the same module with GUM and GranSim.
+A few new strategies.
+
+revision 1.2
+Version V; Strategies95; Type: a -> a
+The type of Strategies has changed from a -> () to a -> a
+All strategies and instances of NFData have been redefined accordingly.
+This branch started off after discussions between PWT, SLPJ and HWL in
+mid Nov (start of development of the actual module: 10/1/96)
+
+revision 1.1 Initial revision
+-----------------------------------------------------------------------------
+-- To use fakeinfo first replace all %%$ by \@
+-- If you have fakeinfo makers in the file you need a slightly modified
+-- version of the lit-deatify script (called by lit2pgm). You get that
+-- version on Suns and Alphas in Glasgow by using
+-- \tr{lit2pgm -H "${HOME}/bin/`hw_os`"}
+-- in your Makefile
+-----------------------------------------------------------------------------
+
+--@node Evaluation Strategies, , ,
+--@chapter Evaluation Strategies
+
+--@menu
+--* Imports and infix declarations::
+--* Strategy Type and Application::
+--* Basic Strategies::
+--* Strategic Function Application::
+--* Marking a Strategy::
+--* Strategy Instances::
+--* Lolita-specific Strategies::
+--@end menu
+
+--@node Imports and infix declarations, Strategy Type and Application, Evaluation Strategies, Evaluation Strategies
+--@section Imports and infix declarations
+
+> module Strategies(
+>#if (__HASKELL1__>=4)
+> module Strategies,
+> module Parallel
+>#else
+> Strategies..
+>#endif
+> ) where
+>
+>#if defined(GRAN) && !(__HASKELL1__>=4)
+> import PreludeGlaST -- only needed for markStrat
+>#endif
+>#if (__HASKELL1__>=4)
+
+<> import Prelude hiding (seq)
+<> import qualified Parallel
+
+> import Parallel
+
+>#else
+> import Parallel renaming (par to par_from_Parallel, seq to seq_from_Parallel)
+>#endif
+
+>#if (__HASKELL1__>=4)
+> import Ix
+> import Array
+>#endif
+
+>#if defined(PAR_GRAN_LIST)
+> import QSort -- tmp (only for parGranList)
+>#endif
+
+I lifted the precedence of @par@ and @seq@ by one level to make @using@ the
+combinator with the weakest precedence.
+Oooops, there seems to be a bug in ghc 0.29 prohibiting another infix
+declaration of @par@ and @seq@ despite renaming the imported versions.
+
+>#if (__HASKELL1__>=4)
+
+<> infixr 2 `par` -- was: 0
+<> infixr 3 `seq` -- was: 1
+
+>#else
+> infixr 0 `par` -- was: 0
+> infixr 1 `seq` -- was: 1
+>#endif
+
+> infixl 0 `using`,`demanding`,`sparking` -- weakest precedence!
+
+> infixr 2 >|| -- another name for par
+> infixr 3 >| -- another name for seq
+> infixl 6 $||, $| -- strategic function application (seq and par)
+> infixl 9 .|, .||, -|, -|| -- strategic (inverse) function composition
+
+> strategy_version = "$Revision: 1.1 $"
+> strategy_id = "$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $"
+
+------------------------------------------------------------------------------
+ Strategy Type, Application and Semantics
+------------------------------------------------------------------------------
+--@node Strategy Type and Application, Basic Strategies, Imports and infix declarations, Evaluation Strategies
+--@section Strategy Type and Application
+
+--@cindex Strategy
+
+> type Done = ()
+> type Strategy a = a -> Done
+
+A strategy takes a value and returns a dummy `done' value to indicate that
+the specifed evaluation has been performed.
+
+The basic combinators for strategies are @par@ and @seq@ but with types that
+indicate that they only combine the results of a strategy application.
+
+NB: This version can be used with Haskell 1.4 (GHC 2.05 and beyond), *but*
+ you won't get strategy checking on seq (only on par)!
+
+The infix fcts >| and >|| are alternative names for `seq` and `par`.
+With the introduction of a Prelude function `seq` separating the Prelude
+function from the Strategy function becomes a pain. The notation also matches
+the notation for strategic function application.
+
+--@cindex par
+--@cindex seq
+--@cindex >|
+--@cindex >||
+
+>#if (__HASKELL1__>=4)
+
+par and seq have the same types as before; >| and >|| are more specific
+and can only be used when composing strategies.
+
+<> par :: Done -> Done -> Done
+<> par = Parallel.par
+<> seq :: a -> b -> b -- that's the real type of seq defined in Prelude
+<> seq = Parallel.seq
+
+> (>|), (>||) :: Done -> Done -> Done
+> {-# INLINE (>|) #-}
+> {-# INLINE (>||) #-}
+> (>|) = Prelude.seq
+> (>||) = Parallel.par
+>#else
+> par, seq, (>|), (>||) :: Done -> Done -> Done
+> par = par_from_Parallel
+> seq = seq_from_Parallel
+> {-# INLINE (>|) #-}
+> {-# INLINE (>||) #-}
+> (>|) = seq
+> (>||) = par
+>#endif
+
+--@cindex using
+
+> using :: a -> Strategy a -> a
+>#if (__HASKELL1__>=4)
+> using x s = s x `seq` x
+>#else
+> using x s = s x `seq_from_Parallel` x
+>#endif
+
+using takes a strategy and a value, and applies the strategy to the
+value before returning the value. Used to express data-oriented parallelism
+
+x `using` s is a projection on x, i.e. both
+
+ a retraction: x `using` s [ x
+ -
+ and idempotent: (x `using` s) `using` s = x `using` s
+
+demanding and sparking are used to express control-oriented
+parallelism. Their second argument is usually a sequence of strategy
+applications combined `par` and `seq`. Sparking should only be used
+with a singleton sequence as it is not necessarily excuted
+
+--@cindex demanding
+--@cindex sparking
+
+> demanding, sparking :: a -> Done -> a
+>#if (__HASKELL1__>=4)
+> demanding = flip Parallel.seq
+> sparking = flip Parallel.par
+>#else
+> demanding = flip seq_from_Parallel
+> sparking = flip par_from_Parallel
+>#endif
+
+sPar and sSeq have been superceded by sparking and demanding: replace
+ e `using` sPar x with e `sparking` x
+ e `using` sSeq x with e `demanding` x
+
+<sPar is a strategy corresponding to par. i.e. x `par` e <=> e `using` sPar x
+<
+<> sPar :: a -> Strategy b
+<> sPar x y = x `par` ()
+<
+<sSeq is a strategy corresponding to seq. i.e. x `seq` e <=> e `using` sSeq x
+<
+<> sSeq :: a -> Strategy b
+<> sSeq x y = x `seq` ()
+
+-----------------------------------------------------------------------------
+ Basic Strategies
+-----------------------------------------------------------------------------
+--@node Basic Strategies, Strategic Function Application, Strategy Type and Application, Evaluation Strategies
+--@section Basic Strategies
+
+r0 performs *no* evaluation on its argument.
+
+--@cindex r0
+
+> r0 :: Strategy a
+> r0 x = ()
+
+rwhnf reduces its argument to weak head normal form.
+
+--@cindex rwhnf
+--@cindex rnf
+--@cindex NFData
+
+>#if defined(__HASKELL98__)
+> rwhnf :: Strategy a
+> rwhnf x = x `seq` ()
+>#elif (__HASKELL1__==4)
+> rwhnf :: Eval a => Strategy a
+> rwhnf x = x `seq` ()
+>#else
+> rwhnf :: Strategy a
+> rwhnf x = x `seq_from_Parallel` ()
+>#endif
+
+>#if defined(__HASKELL98__)
+> class NFData a where
+>#elif (__HASKELL1__>=4)
+> class Eval a => NFData a where
+>#else
+> class NFData a where
+>#endif
+> -- rnf reduces its argument to (head) normal form
+> rnf :: Strategy a
+> -- Default method. Useful for base types. A specific method is necessay for
+> -- constructed types
+> rnf = rwhnf
+>
+> class (NFData a, Integral a) => NFDataIntegral a
+> class (NFData a, Ord a) => NFDataOrd a
+
+------------------------------------------------------------------------------
+ Strategic Function Application
+------------------------------------------------------------------------------
+--@node Strategic Function Application, Marking a Strategy, Basic Strategies, Evaluation Strategies
+--@section Strategic Function Application
+
+The two infix functions @$|@ and @$||@ perform sequential and parallel
+function application, respectively. They are parameterised with a strategy
+that is applied to the argument of the function application. This is very
+handy when writing pipeline parallelism as a sequence of @$@, @$|@ and
+@$||@'s. There is no need of naming intermediate values in this case. The
+separation of algorithm from strategy is achieved by allowing strategies
+only as second arguments to @$|@ and @$||@.
+
+--@cindex $|
+--@cindex $||
+
+> ($|), ($||) :: (a -> b) -> Strategy a -> a -> b
+
+<> f $| s = \ x -> f x `using` \ _ -> s x `seq` ()
+<> f $|| s = \ x -> f x `using` \ _ -> s x `par` ()
+
+> f $| s = \ x -> f x `demanding` s x
+> f $|| s = \ x -> f x `sparking` s x
+
+The same thing for function composition (.| and .||) and inverse function
+composition (-| and -||) for those who read their programs from left to
+right.
+
+--@cindex .|
+--@cindex .||
+--@cindex -|
+--@cindex -||
+
+> (.|), (.||) :: (b -> c) -> Strategy b -> (a -> b) -> (a -> c)
+> (-|), (-||) :: (a -> b) -> Strategy b -> (b -> c) -> (a -> c)
+
+> (.|) f s g = \ x -> let gx = g x
+> in f gx `demanding` s gx
+> (.||) f s g = \ x -> let gx = g x
+> in f gx `sparking` s gx
+
+> (-|) f s g = \ x -> let fx = f x
+> in g fx `demanding` s fx
+> (-||) f s g = \ x -> let fx = f x
+> in g fx `sparking` s fx
+
+------------------------------------------------------------------------------
+ Marking a Strategy
+------------------------------------------------------------------------------
+--@node Marking a Strategy, Strategy Instances, Strategic Function Application, Evaluation Strategies
+--@section Marking a Strategy
+
+Marking a strategy.
+
+Actually, @markStrat@ sticks a label @n@ into the sparkname field of the
+thread executing strategy @s@. Together with a runtime-system that supports
+propagation of sparknames to the children this means that this strategy and
+all its children have the sparkname @n@ (if the static sparkname field in
+the @parGlobal@ annotation contains the value 1). Note, that the @SN@ field
+of starting the marked strategy itself contains the sparkname of the parent
+thread. The END event contains @n@ as sparkname.
+
+--@cindex markStrat
+
+>#if defined(GRAN) && !(__HASKELL1__>=4)
+> markStrat :: Int -> Strategy a -> Strategy a
+> markStrat n s x = unsafePerformPrimIO (
+> _casm_ ``%r = set_sparkname(CurrentTSO, %0);'' n `thenPrimIO` \ z ->
+> returnPrimIO (s x))
+>#endif
+
+-----------------------------------------------------------------------------
+ Strategy Instances and Functions
+-----------------------------------------------------------------------------
+--@node Strategy Instances, Lolita-specific Strategies, Marking a Strategy, Evaluation Strategies
+--@section Strategy Instances
+-----------------------------------------------------------------------------
+ Tuples
+-----------------------------------------------------------------------------
+--@menu
+--* Tuples::
+--* Numbers::
+--* Characters::
+--* Booleans::
+--* Unit::
+--* Lists::
+--* Arrays::
+--@end menu
+
+--@node Tuples, Numbers, Strategy Instances, Strategy Instances
+--@subsection Tuples
+
+We currently support up to 9-tuples. If you need longer tuples you have to
+add the instance explicitly to your program.
+
+> instance (NFData a, NFData b) => NFData (a,b) where
+> rnf (x,y) = rnf x `seq` rnf y
+
+> instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where
+> rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z
+
+> instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where
+> rnf (x1,x2,x3,x4) = rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) =>
+> NFData (a1, a2, a3, a4, a5) where
+> rnf (x1, x2, x3, x4, x5) =
+> rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4 `seq`
+> rnf x5
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) =>
+> NFData (a1, a2, a3, a4, a5, a6) where
+> rnf (x1, x2, x3, x4, x5, x6) =
+> rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4 `seq`
+> rnf x5 `seq`
+> rnf x6
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) =>
+> NFData (a1, a2, a3, a4, a5, a6, a7) where
+> rnf (x1, x2, x3, x4, x5, x6, x7) =
+> rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4 `seq`
+> rnf x5 `seq`
+> rnf x6 `seq`
+> rnf x7
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) =>
+> NFData (a1, a2, a3, a4, a5, a6, a7, a8) where
+> rnf (x1, x2, x3, x4, x5, x6, x7, x8) =
+> rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4 `seq`
+> rnf x5 `seq`
+> rnf x6 `seq`
+> rnf x7 `seq`
+> rnf x8
+
+> -- code automatically inserted by `hwl-insert-NFData-n-tuple'
+> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) =>
+> NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
+> rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) =
+> rnf x1 `seq`
+> rnf x2 `seq`
+> rnf x3 `seq`
+> rnf x4 `seq`
+> rnf x5 `seq`
+> rnf x6 `seq`
+> rnf x7 `seq`
+> rnf x8 `seq`
+> rnf x9
+
+--@cindex seqPair
+
+> seqPair :: Strategy a -> Strategy b -> Strategy (a,b)
+> seqPair strata stratb (x,y) = strata x `seq` stratb y
+
+--@cindex parPair
+
+> parPair :: Strategy a -> Strategy b -> Strategy (a,b)
+> parPair strata stratb (x,y) = strata x `par` stratb y `par` ()
+
+The reason for the second `par` is so that the strategy terminates
+quickly. This is important if the strategy is used as the 1st argument of a seq
+
+--@cindex seqTriple
+
+> seqTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
+> seqTriple strata stratb stratc p@(x,y,z) =
+> strata x `seq`
+> stratb y `seq`
+> stratc z
+
+--@cindex parTriple
+
+> parTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c)
+> parTriple strata stratb stratc (x,y,z) =
+> strata x `par`
+> stratb y `par`
+> stratc z `par`
+> ()
+
+-----------------------------------------------------------------------------
+ Numbers
+-----------------------------------------------------------------------------
+--@node Numbers, Characters, Tuples, Strategy Instances
+--@subsection Numbers
+
+Weak head normal form and normal form are identical for integers, so the
+default rnf is sufficient.
+
+> instance NFData Int
+> instance NFData Integer
+> instance NFData Float
+> instance NFData Double
+
+> instance NFDataIntegral Int
+> instance NFDataOrd Int
+
+Rational and complex numbers.
+
+>#if !(__HASKELL1__>=4)
+> instance (NFData a) => NFData (Ratio a) where
+> rnf (x:%y) = rnf x `seq`
+> rnf y `seq`
+> ()
+
+> instance (NFData a) => NFData (Complex a) where
+> rnf (x:+y) = rnf x `seq`
+> rnf y `seq`
+> ()
+>#endif
+
+-----------------------------------------------------------------------------
+ Characters
+-----------------------------------------------------------------------------
+--@node Characters, Booleans, Numbers, Strategy Instances
+--@subsection Characters
+
+> instance NFData Char
+
+-----------------------------------------------------------------------------
+ Bools
+-----------------------------------------------------------------------------
+--@node Booleans, Unit, Characters, Strategy Instances
+--@subsection Booleans
+
+> instance NFData Bool
+
+-----------------------------------------------------------------------------
+ Unit
+-----------------------------------------------------------------------------
+--@node Unit, Lists, Booleans, Strategy Instances
+--@subsection Unit
+
+> instance NFData ()
+
+-----------------------------------------------------------------------------
+ Lists
+----------------------------------------------------------------------------
+--@node Lists, Arrays, Unit, Strategy Instances
+--@subsection Lists
+
+> instance NFData a => NFData [a] where
+> rnf [] = ()
+> rnf (x:xs) = rnf x `seq` rnf xs
+
+--@menu
+--* Parallel Strategies for Lists::
+--* Sequential Strategies for Lists::
+--@end menu
+
+----------------------------------------------------------------------------
+ Lists: Parallel Strategies
+----------------------------------------------------------------------------
+--@node Parallel Strategies for Lists, Sequential Strategies for Lists, Lists, Lists
+--@subsubsection Parallel Strategies for Lists
+
+Applies a strategy to every element of a list in parallel
+
+--@cindex parList
+
+> parList :: Strategy a -> Strategy [a]
+> parList strat [] = ()
+> parList strat (x:xs) = strat x `par` (parList strat xs)
+
+Applies a strategy to the first n elements of a list in parallel
+
+--@cindex parListN
+
+> parListN :: (Integral b) => b -> Strategy a -> Strategy [a]
+> parListN n strat [] = ()
+> parListN 0 strat xs = ()
+> parListN n strat (x:xs) = strat x `par` (parListN (n-1) strat xs)
+
+Evaluates N elements of the spine of the argument list and applies
+`strat' to the Nth element (if there is one) in parallel with the
+result. e.g. parListNth 2 [e1, e2, e3] evaluates e2
+
+--@cindex parListNth
+
+> parListNth :: Int -> Strategy a -> Strategy [a]
+> parListNth n strat xs
+> | null rest = ()
+> | otherwise = strat (head rest) `par` ()
+> where
+> rest = drop n xs
+
+parListChunk sequentially applies a strategy to chunks
+(sub-sequences) of a list in parallel. Useful to increase grain size
+
+--@cindex parListChunk
+
+> parListChunk :: Int -> Strategy a -> Strategy [a]
+> parListChunk n strat [] = ()
+> parListChunk n strat xs = seqListN n strat xs `par`
+> parListChunk n strat (drop n xs)
+
+parMap applies a function to each element of the argument list in
+parallel. The result of the function is evaluated using `strat'
+
+--@cindex parMap
+
+> parMap :: Strategy b -> (a -> b) -> [a] -> [b]
+> parMap strat f xs = map f xs `using` parList strat
+
+parFlatMap uses parMap to apply a list-valued function to each
+element of the argument list in parallel. The result of the function
+is evaluated using `strat'
+
+--@cindex parFlatMap
+
+> parFlatMap :: Strategy [b] -> (a -> [b]) -> [a] -> [b]
+> parFlatMap strat f xs = concat (parMap strat f xs)
+
+parZipWith zips together two lists with a function z in parallel
+
+--@cindex parZipWith
+
+> parZipWith :: Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c]
+> parZipWith strat z as bs =
+> zipWith z as bs `using` parList strat
+
+----------------------------------------------------------------------------
+ Lists: Sequential Strategies
+----------------------------------------------------------------------------
+--@node Sequential Strategies for Lists, , Parallel Strategies for Lists, Lists
+--@subsubsection Sequential Strategies for Lists
+
+Sequentially applies a strategy to each element of a list
+
+--@cindex seqList
+
+> seqList :: Strategy a -> Strategy [a]
+> seqList strat [] = ()
+> seqList strat (x:xs) = strat x `seq` (seqList strat xs)
+
+Sequentially applies a strategy to the first n elements of a list
+
+--@cindex seqListN
+
+> seqListN :: (Integral a) => a -> Strategy b -> Strategy [b]
+> seqListN n strat [] = ()
+> seqListN 0 strat xs = ()
+> seqListN n strat (x:xs) = strat x `seq` (seqListN (n-1) strat xs)
+
+seqListNth applies a strategy to the Nth element of it's argument
+(if there is one) before returning the result. e.g. seqListNth 2 [e1,
+e2, e3] evaluates e2
+
+--@cindex seqListNth
+
+>#if (__HASKELL1__>=4)
+> seqListNth :: Int -> Strategy b -> Strategy [b]
+>#else
+> seqListNth :: (Integral a) => a -> Strategy b -> Strategy [b]
+>#endif
+> seqListNth n strat xs
+> | null rest = ()
+> | otherwise = strat (head rest)
+> where
+> rest = drop n xs
+
+Parallel n-buffer function added for the revised version of the strategies
+paper. @parBuffer@ supersedes the older @fringeList@. It has the same
+semantics.
+
+--@cindex parBuffer
+
+> parBuffer :: Int -> Strategy a -> [a] -> [a]
+> parBuffer n s xs =
+> return xs (start n xs)
+> where
+> return (x:xs) (y:ys) = (x:return xs ys) `sparking` s y
+> return xs [] = xs
+>
+> start n [] = []
+> start 0 ys = ys
+> start n (y:ys) = start (n-1) ys `sparking` s y
+
+fringeList implements a `rolling buffer' of length n, i.e.applies a
+strategy to the nth element of list when the head is demanded. More
+precisely:
+
+ semantics: fringeList n s = id :: [b] -> [b]
+ dynamic behaviour: evalutates the nth element of the list when the
+ head is demanded.
+
+The idea is to provide a `rolling buffer' of length n.
+
+--@cindex fringeList
+
+<> fringeList :: (Integral a) => a -> Strategy b -> [b] -> [b]
+<> fringeList n strat [] = []
+<> fringeList n strat (r:rs) =
+<> seqListNth n strat rs `par`
+<> r:fringeList n strat rs
+
+------------------------------------------------------------------------------
+ Arrays
+------------------------------------------------------------------------------
+--@node Arrays, , Lists, Strategy Instances
+--@subsection Arrays
+
+> instance (Ix a, NFData a, NFData b) => NFData (Array a b) where
+> rnf x = rnf (bounds x) `seq` seqList rnf (elems x) `seq` ()
+
+Apply a strategy to all elements of an array in parallel. This can be done
+either in sequentially or in parallel (same as with lists, really).
+
+> seqArr :: (Ix b) => Strategy a -> Strategy (Array b a)
+> seqArr s arr = seqList s (elems arr)
+
+> parArr :: (Ix b) => Strategy a -> Strategy (Array b a)
+> parArr s arr = parList s (elems arr)
+
+Associations maybe useful even withou mentioning Arrays.
+
+See: .../lib/prelude/TyArrays.hs:
+data Assoc a b = a := b deriving ()
+
+>#if (__HASKELL1__<4)
+> instance (NFData a, NFData b) => NFData (Assoc a b) where
+> rnf (x := y) = rnf x `seq` rnf y `seq` ()
+>#endif
+
+------------------------------------------------------------------------------
+ Some strategies specific for Lolita
+------------------------------------------------------------------------------
+--@node Lolita-specific Strategies, Index, Strategy Instances, Evaluation Strategies
+--@section Lolita-specific Strategies
+
+The following is useful in mergePenGroups
+
+--@cindex fstPairFstList
+
+> fstPairFstList :: (NFData a) => Strategy [(a,b)]
+> fstPairFstList = seqListN 1 (seqPair rwhnf r0)
+
+Some HACKs for Lolita. AFAIK force is just another name for our rnf and
+sforce is a shortcut (definition here is identical to the one in Force.lhs)
+
+> force :: (NFData a) => a -> a
+> sforce :: (NFData a) => a -> b -> b
+
+Same as definition below
+
+<> force x = rnf x `seq` x
+
+> force = id $| rnf
+>#if (__HASKELL1__>=4)
+> sforce x y = force x `seq` y
+>#else
+> sforce x y = force x `seq_from_Parallel` y
+>#endif
+
+--@node Bowing-alg specific strategies
+--@section Bowing-alg specific strategies
+
+NB: this strategy currently needs the quicksort implementation from the hbc syslib
+
+>#if defined(PAR_GRAN_LIST)
+> parGranList :: Strategy a -> (a -> Int) -> [a] -> Strategy [a]
+> parGranList s gran_estim l_in = \ l_out ->
+> parListByIdx s l_out $
+> sortedIdx gran_list (sortLe ( \ (i,_) (j,_) -> i>j) gran_list)
+> where -- spark list elems of l in the order specified by (i:idxs)
+> parListByIdx s l [] = ()
+> parListByIdx s l (i:idxs) = parListByIdx s l idxs `sparking` s (l!!i)
+> -- get the index of y in the list
+> idx y [] = error "idx: x not in l"
+> idx y ((x,_):xs) | y==x = 0
+> | otherwise = (idx y xs)+1
+> -- the `schedule' for sparking: list of indices of sorted input list
+> sortedIdx l idxs = [ idx x l | (x,_) <- idxs ]
+> -- add granularity info to elems of the input list
+> gran_list = map (\ l -> (gran_estim l, l)) l_in
+>#endif
+
+--@node Index, , Lolita-specific Strategies, Evaluation Strategies
+--@section Index
+
+--@index
+--* $|:: @cindex\s-+$|
+--* $||:: @cindex\s-+$||
+--* -|:: @cindex\s-+-|
+--* -||:: @cindex\s-+-||
+--* .|:: @cindex\s-+.|
+--* .||:: @cindex\s-+.||
+--* NFData:: @cindex\s-+NFData
+--* Strategy:: @cindex\s-+Strategy
+--* demanding:: @cindex\s-+demanding
+--* fringeList:: @cindex\s-+fringeList
+--* fstPairFstList:: @cindex\s-+fstPairFstList
+--* markStrat:: @cindex\s-+markStrat
+--* parBuffer:: @cindex\s-+parBuffer
+--* parFlatMap:: @cindex\s-+parFlatMap
+--* parList:: @cindex\s-+parList
+--* parListChunk:: @cindex\s-+parListChunk
+--* parListN:: @cindex\s-+parListN
+--* parListNth:: @cindex\s-+parListNth
+--* parMap:: @cindex\s-+parMap
+--* parPair:: @cindex\s-+parPair
+--* parTriple:: @cindex\s-+parTriple
+--* parZipWith:: @cindex\s-+parZipWith
+--* r0:: @cindex\s-+r0
+--* rnf:: @cindex\s-+rnf
+--* rwhnf:: @cindex\s-+rwhnf
+--* seqList:: @cindex\s-+seqList
+--* seqListN:: @cindex\s-+seqListN
+--* seqListNth:: @cindex\s-+seqListNth
+--* seqPair:: @cindex\s-+seqPair
+--* seqTriple:: @cindex\s-+seqTriple
+--* sparking:: @cindex\s-+sparking
+--* using:: @cindex\s-+using
+--@end index
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Array.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Basic non-strict arrays.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array
+
+ (
+ module Data.Ix -- export all of Ix
+ , Array -- Array type is abstract
+
+ , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+ , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b
+ , (!) -- :: (Ix a) => Array a b -> a -> b
+ , bounds -- :: (Ix a) => Array a b -> (a,a)
+ , indices -- :: (Ix a) => Array a b -> [a]
+ , elems -- :: (Ix a) => Array a b -> [b]
+ , assocs -- :: (Ix a) => Array a b -> [(a,b)]
+ , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+ , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+ , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+ , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b
+
+ -- Array instances:
+ --
+ -- Ix a => Functor (Array a)
+ -- (Ix a, Eq b) => Eq (Array a b)
+ -- (Ix a, Ord b) => Ord (Array a b)
+ -- (Ix a, Show a, Show b) => Show (Array a b)
+ -- (Ix a, Read a, Read b) => Read (Array a b)
+ --
+
+ -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+
+ ) where
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import Data.Ix
+import GHC.Arr -- Most of the hard work is done here
+import GHC.Err ( undefined )
+#endif
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+
+#ifdef __HUGS__
+ ------------ HUGS (rest of file) --------------------
+import PrelPrim ( PrimArray
+ , runST
+ , primNewArray
+ , primWriteArray
+ , primReadArray
+ , primUnsafeFreezeArray
+ , primIndexArray
+ )
+import Ix
+import List( (\\) )
+
+infixl 9 !, //
+
+-- -----------------------------------------------------------------------------
+-- The Array type
+
+data Array ix elt = Array (ix,ix) (PrimArray elt)
+
+array :: Ix a => (a,a) -> [(a,b)] -> Array a b
+array ixs@(ix_start, ix_end) ivs = runST (do
+ { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom
+ ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs
+ ; arr <- primUnsafeFreezeArray mut_arr
+ ; return (Array ixs arr)
+ }
+ )
+ where
+ arrEleBottom = error "(Array.!): undefined array element"
+
+listArray :: Ix a => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: Ix a => Array a b -> a -> b
+(Array bounds arr) ! i = primIndexArray arr (index bounds i)
+
+bounds :: Ix a => Array a b -> (a,a)
+bounds (Array b _) = b
+
+indices :: Ix a => Array a b -> [a]
+indices = range . bounds
+
+elems :: Ix a => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: Ix a => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: Ix a => Array a b -> [(a,b)] -> Array a b
+(//) a us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+
+instance (Ix a) => Functor (Array a) where
+ fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a]
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ a <= a' = assocs a <= assocs a'
+
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+#endif /* __HUGS__ */
--- /dev/null
+{-# OPTIONS -monly-3-regs #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.Base
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Base.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Basis for IArray and MArray. Not intended for external consumption;
+-- use IArray or MArray instead.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.Base where
+
+import Prelude
+
+import Data.Ix ( Ix, range, index, rangeSize )
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr ( STArray, unsafeIndex )
+import qualified GHC.Arr
+import GHC.ST ( ST(..), runST )
+import GHC.Base
+import GHC.Word ( Word(..) )
+import GHC.Ptr ( Ptr(..), FunPtr(..) )
+import GHC.Float ( Float(..), Double(..) )
+import GHC.Stable ( StablePtr(..) )
+import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) )
+import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) )
+#endif
+
+import Data.Dynamic
+#include "Dynamic.h"
+
+-----------------------------------------------------------------------------
+-- Class of immutable arrays
+
+class HasBounds a where
+ bounds :: Ix i => a i e -> (i,i)
+
+class HasBounds a => IArray a e where
+ unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> a i e
+ unsafeAt :: Ix i => a i e -> Int -> e
+ unsafeReplace :: Ix i => a i e -> [(Int, e)] -> a i e
+ unsafeAccum :: Ix i => (e -> e' -> e) -> a i e -> [(Int, e')] -> a i e
+ unsafeAccumArray :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> a i e
+
+ unsafeReplace arr ies = runST (unsafeReplaceST arr ies >>= unsafeFreeze)
+ unsafeAccum f arr ies = runST (unsafeAccumST f arr ies >>= unsafeFreeze)
+ unsafeAccumArray f e lu ies = runST (unsafeAccumArrayST f e lu ies >>= unsafeFreeze)
+
+{-# INLINE unsafeReplaceST #-}
+unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e)
+unsafeReplaceST arr ies = do
+ marr <- thaw arr
+ sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+ return marr
+
+{-# INLINE unsafeAccumST #-}
+unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e)
+unsafeAccumST f arr ies = do
+ marr <- thaw arr
+ sequence_ [do
+ old <- unsafeRead marr i
+ unsafeWrite marr i (f old new)
+ | (i, new) <- ies]
+ return marr
+
+{-# INLINE unsafeAccumArrayST #-}
+unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e)
+unsafeAccumArrayST f e (l,u) ies = do
+ marr <- newArray (l,u) e
+ sequence_ [do
+ old <- unsafeRead marr i
+ unsafeWrite marr i (f old new)
+ | (i, new) <- ies]
+ return marr
+
+{-# INLINE array #-}
+array :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e
+array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+-- Since unsafeFreeze is not guaranteed to be only a cast, we will
+-- use unsafeArray and zip instead of a specialized loop to implement
+-- listArray, unlike Array.listArray, even though it generates some
+-- unnecessary heap allocation. Will use the loop only when we have
+-- fast unsafeFreeze, namely for Array and UArray (well, they cover
+-- almost all cases).
+
+{-# INLINE listArray #-}
+listArray :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
+listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es)
+
+{-# INLINE listArrayST #-}
+listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e)
+listArrayST (l,u) es = do
+ marr <- newArray_ (l,u)
+ let n = rangeSize (l,u)
+ let fillFromList i xs | i == n = return ()
+ | otherwise = case xs of
+ [] -> return ()
+ y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+ fillFromList 0 es
+ return marr
+
+{-# RULES
+"listArray/Array" listArray =
+ \lu es -> runST (listArrayST lu es >>= GHC.Arr.unsafeFreezeSTArray)
+ #-}
+
+{-# INLINE listUArrayST #-}
+listUArrayST :: (MArray (STUArray s) e (ST s), Ix i)
+ => (i,i) -> [e] -> ST s (STUArray s i e)
+listUArrayST (l,u) es = do
+ marr <- newArray_ (l,u)
+ let n = rangeSize (l,u)
+ let fillFromList i xs | i == n = return ()
+ | otherwise = case xs of
+ [] -> return ()
+ y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+ fillFromList 0 es
+ return marr
+
+-- I don't know how to write a single rule for listUArrayST, because
+-- the type looks like constrained over 's', which runST doesn't
+-- like. In fact all MArray (STUArray s) instances are polymorphic
+-- wrt. 's', but runST can't know that.
+
+-- I would like to write a rule for listUArrayST (or listArray or
+-- whatever) applied to unpackCString#. Unfortunately unpackCString#
+-- calls seem to be floated out, then floated back into the middle
+-- of listUArrayST, so I was not able to do this.
+
+{-# RULES
+"listArray/UArray/Bool" listArray = \lu (es :: [Bool]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Char" listArray = \lu (es :: [Char]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int" listArray = \lu (es :: [Int]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word" listArray = \lu (es :: [Word]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Ptr" listArray = \lu (es :: [Ptr a]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/FunPtr" listArray = \lu (es :: [FunPtr a]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Float" listArray = \lu (es :: [Float]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Double" listArray = \lu (es :: [Double]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/StablePtr" listArray = \lu (es :: [StablePtr a]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int8" listArray = \lu (es :: [Int8]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int16" listArray = \lu (es :: [Int16]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int32" listArray = \lu (es :: [Int32]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Int64" listArray = \lu (es :: [Int64]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word8" listArray = \lu (es :: [Word8]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word16" listArray = \lu (es :: [Word16]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word32" listArray = \lu (es :: [Word32]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+"listArray/UArray/Word64" listArray = \lu (es :: [Word64]) ->
+ runST (listUArrayST lu es >>= unsafeFreezeSTUArray)
+ #-}
+
+{-# INLINE (!) #-}
+(!) :: (IArray a e, Ix i) => a i e -> i -> e
+arr ! i | (l,u) <- bounds arr = unsafeAt arr (index (l,u) i)
+
+{-# INLINE indices #-}
+indices :: (HasBounds a, Ix i) => a i e -> [i]
+indices arr | (l,u) <- bounds arr = range (l,u)
+
+{-# INLINE elems #-}
+elems :: (IArray a e, Ix i) => a i e -> [e]
+elems arr | (l,u) <- bounds arr =
+ [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE assocs #-}
+assocs :: (IArray a e, Ix i) => a i e -> [(i, e)]
+assocs arr | (l,u) <- bounds arr =
+ [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)]
+
+{-# INLINE accumArray #-}
+accumArray :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e
+accumArray f init (l,u) ies =
+ unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE (//) #-}
+(//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
+arr // ies | (l,u) <- bounds arr =
+ unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE accum #-}
+accum :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
+accum f arr ies | (l,u) <- bounds arr =
+ unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies]
+
+{-# INLINE amap #-}
+amap :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
+amap f arr | (l,u) <- bounds arr =
+ unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE ixmap #-}
+ixmap :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
+ixmap (l,u) f arr =
+ unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)]
+
+-----------------------------------------------------------------------------
+-- Normal polymorphic arrays
+
+instance HasBounds GHC.Arr.Array where
+ {-# INLINE bounds #-}
+ bounds = GHC.Arr.bounds
+
+instance IArray GHC.Arr.Array e where
+ {-# INLINE unsafeArray #-}
+ unsafeArray = GHC.Arr.unsafeArray
+ {-# INLINE unsafeAt #-}
+ unsafeAt = GHC.Arr.unsafeAt
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace = GHC.Arr.unsafeReplace
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum = GHC.Arr.unsafeAccum
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray = GHC.Arr.unsafeAccumArray
+
+-----------------------------------------------------------------------------
+-- Flat unboxed arrays
+
+data UArray i e = UArray !i !i ByteArray#
+
+INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray")
+
+instance HasBounds UArray where
+ {-# INLINE bounds #-}
+ bounds (UArray l u _) = (l,u)
+
+{-# INLINE unsafeArrayUArray #-}
+unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
+ => (i,i) -> [(Int, e)] -> ST s (UArray i e)
+unsafeArrayUArray (l,u) ies = do
+ marr <- newArray_ (l,u)
+ sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+ unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeFreezeSTUArray #-}
+unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e)
+unsafeFreezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
+ case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) ->
+ (# s2#, UArray l u arr# #) }
+
+{-# INLINE unsafeReplaceUArray #-}
+unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i)
+ => UArray i e -> [(Int, e)] -> ST s (UArray i e)
+unsafeReplaceUArray arr ies = do
+ marr <- thawSTUArray arr
+ sequence_ [unsafeWrite marr i e | (i, e) <- ies]
+ unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeAccumUArray #-}
+unsafeAccumUArray :: (MArray (STUArray s) e (ST s), Ix i)
+ => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e)
+unsafeAccumUArray f arr ies = do
+ marr <- thawSTUArray arr
+ sequence_ [do
+ old <- unsafeRead marr i
+ unsafeWrite marr i (f old new)
+ | (i, new) <- ies]
+ unsafeFreezeSTUArray marr
+
+{-# INLINE unsafeAccumArrayUArray #-}
+unsafeAccumArrayUArray :: (MArray (STUArray s) e (ST s), Ix i)
+ => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e)
+unsafeAccumArrayUArray f init (l,u) ies = do
+ marr <- newArray (l,u) init
+ sequence_ [do
+ old <- unsafeRead marr i
+ unsafeWrite marr i (f old new)
+ | (i, new) <- ies]
+ unsafeFreezeSTUArray marr
+
+{-# INLINE eqUArray #-}
+eqUArray :: (IArray UArray e, Ix i, Eq e) => UArray i e -> UArray i e -> Bool
+eqUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else
+ l1 == l2 && u1 == u2 &&
+ and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]]
+
+{-# INLINE cmpUArray #-}
+cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering
+cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2)
+
+{-# INLINE cmpIntUArray #-}
+cmpIntUArray :: (IArray UArray e, Ord e) => UArray Int e -> UArray Int e -> Ordering
+cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) =
+ if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else
+ if rangeSize (l2,u2) == 0 then GT else
+ case compare l1 l2 of
+ EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1]
+ other -> other
+ where
+ cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of
+ EQ -> rest
+ other -> other
+
+{-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-}
+
+showsUArray :: (IArray UArray e, Ix i, Show i, Show e)
+ => Int -> UArray i e -> ShowS
+showsUArray p a =
+ showParen (p > 9) $
+ showString "array " .
+ shows (bounds a) .
+ showChar ' ' .
+ shows (assocs a)
+
+-----------------------------------------------------------------------------
+-- Flat unboxed arrays: instances
+
+instance IArray UArray Bool where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) =
+ (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)
+ `neWord#` int2Word# 0#
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Char where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (Ptr a) where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (FunPtr a) where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Float where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Double where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray (StablePtr a) where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int8 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int16 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int32 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Int64 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word8 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word16 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word32 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance IArray UArray Word64 where
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#)
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies)
+
+instance Ix ix => Eq (UArray ix Bool) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Char) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (Ptr a)) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (FunPtr a)) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Float) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Double) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix (StablePtr a)) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int8) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int16) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int32) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Int64) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word8) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word16) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word32) where
+ (==) = eqUArray
+
+instance Ix ix => Eq (UArray ix Word64) where
+ (==) = eqUArray
+
+instance Ix ix => Ord (UArray ix Bool) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Char) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix (Ptr a)) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix (FunPtr a)) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Float) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Double) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int8) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int16) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int32) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Int64) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word8) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word16) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word32) where
+ compare = cmpUArray
+
+instance Ix ix => Ord (UArray ix Word64) where
+ compare = cmpUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Bool) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Char) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Float) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Double) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int8) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int16) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int32) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Int64) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word8) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word16) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word32) where
+ showsPrec = showsUArray
+
+instance (Ix ix, Show ix) => Show (UArray ix Word64) where
+ showsPrec = showsUArray
+
+-----------------------------------------------------------------------------
+-- Mutable arrays
+
+{-# NOINLINE arrEleBottom #-}
+arrEleBottom :: a
+arrEleBottom = error "MArray: undefined array element"
+
+class (HasBounds a, Monad m) => MArray a e m where
+ newArray :: Ix i => (i,i) -> e -> m (a i e)
+ newArray_ :: Ix i => (i,i) -> m (a i e)
+ unsafeRead :: Ix i => a i e -> Int -> m e
+ unsafeWrite :: Ix i => a i e -> Int -> e -> m ()
+
+ newArray (l,u) init = do
+ marr <- newArray_ (l,u)
+ sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]]
+ return marr
+
+ newArray_ (l,u) = newArray (l,u) arrEleBottom
+
+ -- newArray takes an initialiser which all elements of
+ -- the newly created array are initialised to. newArray_ takes
+ -- no initialiser, it is assumed that the array is initialised with
+ -- "undefined" values.
+
+ -- why not omit newArray_? Because in the unboxed array case we would
+ -- like to omit the initialisation altogether if possible. We can't do
+ -- this for boxed arrays, because the elements must all have valid values
+ -- at all times in case of garbage collection.
+
+ -- why not omit newArray? Because in the boxed case, we can omit the
+ -- default initialisation with undefined values if we *do* know the
+ -- initial value and it is constant for all elements.
+
+{-# INLINE newListArray #-}
+newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
+newListArray (l,u) es = do
+ marr <- newArray_ (l,u)
+ let n = rangeSize (l,u)
+ let fillFromList i xs | i == n = return ()
+ | otherwise = case xs of
+ [] -> return ()
+ y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys
+ fillFromList 0 es
+ return marr
+
+{-# INLINE readArray #-}
+readArray :: (MArray a e m, Ix i) => a i e -> i -> m e
+readArray marr i | (l,u) <- bounds marr =
+ unsafeRead marr (index (l,u) i)
+
+{-# INLINE writeArray #-}
+writeArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
+writeArray marr i e | (l,u) <- bounds marr =
+ unsafeWrite marr (index (l,u) i) e
+
+{-# INLINE getElems #-}
+getElems :: (MArray a e m, Ix i) => a i e -> m [e]
+getElems marr | (l,u) <- bounds marr =
+ sequence [unsafeRead marr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# INLINE getAssocs #-}
+getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
+getAssocs marr | (l,u) <- bounds marr =
+ sequence [do e <- unsafeRead marr (index (l,u) i); return (i,e)
+ | i <- range (l,u)]
+
+{-# INLINE mapArray #-}
+mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
+mapArray f marr | (l,u) <- bounds marr = do
+ marr' <- newArray_ (l,u)
+ sequence_ [do
+ e <- unsafeRead marr i
+ unsafeWrite marr' i (f e)
+ | i <- [0 .. rangeSize (l,u) - 1]]
+ return marr'
+
+{-# INLINE mapIndices #-}
+mapIndices :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
+mapIndices (l,u) f marr = do
+ marr' <- newArray_ (l,u)
+ sequence_ [do
+ e <- readArray marr (f i)
+ unsafeWrite marr' (unsafeIndex (l,u) i) e
+ | i <- range (l,u)]
+ return marr'
+
+-----------------------------------------------------------------------------
+-- Polymorphic non-strict mutable arrays (ST monad)
+
+instance HasBounds (STArray s) where
+ {-# INLINE bounds #-}
+ bounds = GHC.Arr.boundsSTArray
+
+instance MArray (STArray s) e (ST s) where
+ {-# INLINE newArray #-}
+ newArray = GHC.Arr.newSTArray
+ {-# INLINE unsafeRead #-}
+ unsafeRead = GHC.Arr.unsafeReadSTArray
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite = GHC.Arr.unsafeWriteSTArray
+
+-----------------------------------------------------------------------------
+-- Typeable instance for STArray
+
+sTArrayTc :: TyCon
+sTArrayTc = mkTyCon "STArray"
+
+instance (Typeable a, Typeable b, Typeable c) => Typeable (STArray a b c) where
+ typeOf a = mkAppTy sTArrayTc [typeOf ((undefined :: STArray a b c -> a) a),
+ typeOf ((undefined :: STArray a b c -> b) a),
+ typeOf ((undefined :: STArray a b c -> c) a)]
+
+-----------------------------------------------------------------------------
+-- Flat unboxed mutable arrays (ST monad)
+
+data STUArray s i a = STUArray !i !i (MutableByteArray# s)
+
+INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray")
+
+instance HasBounds (STUArray s) where
+ {-# INLINE bounds #-}
+ bounds (STUArray l u _) = (l,u)
+
+instance MArray (STUArray s) Bool (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) ->
+ (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) e = ST $ \s1# ->
+ case bOOL_INDEX i# of { j# ->
+ case readWordArray# marr# j# s1# of { (# s2#, old# #) ->
+ case if e then old# `or#` bOOL_BIT i#
+ else old# `and#` bOOL_NOT_BIT i# of { e# ->
+ case writeWordArray# marr# j# e# s2# of { s3# ->
+ (# s3#, () #) }}}}
+
+instance MArray (STUArray s) Char (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWideCharArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, C# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (C# e#) = ST $ \s1# ->
+ case writeWideCharArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Int (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readIntArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, I# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (I# e#) = ST $ \s1# ->
+ case writeIntArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Word (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWordArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, W# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (W# e#) = ST $ \s1# ->
+ case writeWordArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) (Ptr a) (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, Ptr e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (Ptr e#) = ST $ \s1# ->
+ case writeAddrArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) (FunPtr a) (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readAddrArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, FunPtr e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (FunPtr e#) = ST $ \s1# ->
+ case writeAddrArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Float (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (fLOAT_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readFloatArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, F# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (F# e#) = ST $ \s1# ->
+ case writeFloatArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Double (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (dOUBLE_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readDoubleArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, D# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (D# e#) = ST $ \s1# ->
+ case writeDoubleArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) (StablePtr a) (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readStablePtrArray# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2# , StablePtr e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (StablePtr e#) = ST $ \s1# ->
+ case writeStablePtrArray# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Int8 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# n# s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readInt8Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, I8# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (I8# e#) = ST $ \s1# ->
+ case writeInt8Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Int16 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readInt16Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, I16# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (I16# e#) = ST $ \s1# ->
+ case writeInt16Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Int32 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readInt32Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, I32# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (I32# e#) = ST $ \s1# ->
+ case writeInt32Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Int64 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readInt64Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, I64# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# ->
+ case writeInt64Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Word8 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# n# s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWord8Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, W8# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (W8# e#) = ST $ \s1# ->
+ case writeWord8Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Word16 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWord16Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, W16# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (W16# e#) = ST $ \s1# ->
+ case writeWord16Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Word32 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWord32Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, W32# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (W32# e#) = ST $ \s1# ->
+ case writeWord32Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+instance MArray (STUArray s) Word64 (ST s) where
+ {-# INLINE newArray_ #-}
+ newArray_ (l,u) = ST $ \s1# ->
+ case rangeSize (l,u) of { I# n# ->
+ case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) ->
+ (# s2#, STUArray l u marr# #) }}
+ {-# INLINE unsafeRead #-}
+ unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# ->
+ case readWord64Array# marr# i# s1# of { (# s2#, e# #) ->
+ (# s2#, W64# e# #) }
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# ->
+ case writeWord64Array# marr# i# e# s1# of { s2# ->
+ (# s2#, () #) }
+
+-----------------------------------------------------------------------------
+-- Translation between elements and bytes
+
+#include "config.h"
+
+bOOL_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int#
+bOOL_SCALE n# = bOOL_INDEX (n# +# last#) where I# last# = SIZEOF_VOID_P - 1
+wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_VOID_P
+dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_DOUBLE
+fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_FLOAT
+
+bOOL_INDEX :: Int# -> Int#
+#if SIZEOF_VOID_P == 4
+bOOL_INDEX i# = i# `iShiftRA#` 5#
+#else
+bOOL_INDEX i# = i# `iShiftRA#` 6#
+#endif
+
+bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word#
+bOOL_BIT n# = int2Word# 1# `shiftL#` (word2Int# (int2Word# n# `and#` mask#))
+ where W# mask# = SIZEOF_VOID_P * 8 - 1
+bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound
+
+-----------------------------------------------------------------------------
+-- Freezing
+
+freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+freeze marr | (l,u) <- bounds marr = do
+ ies <- sequence [do e <- unsafeRead marr i; return (i,e)
+ | i <- [0 .. rangeSize (l,u) - 1]]
+ return (unsafeArray (l,u) ies)
+
+freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e)
+freezeSTUArray (STUArray l u marr#) = ST $ \s1# ->
+ case sizeofMutableByteArray# marr# of { n# ->
+ case newByteArray# n# s1# of { (# s2#, marr'# #) ->
+ case unsafeCoerce# memcpy marr'# marr# n# s2# of { (# s3#, () #) ->
+ case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) ->
+ (# s4#, UArray l u arr# #) }}}}
+
+{-# RULES
+"freeze/STArray" freeze = GHC.Arr.freezeSTArray
+"freeze/STUArray" freeze = freezeSTUArray
+ #-}
+
+-- In-place conversion of mutable arrays to immutable ones places
+-- a proof obligation on the user: no other parts of your code can
+-- have a reference to the array at the point where you unsafely
+-- freeze it (and, subsequently mutate it, I suspect).
+
+{-# INLINE unsafeFreeze #-}
+unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+unsafeFreeze = freeze
+
+{-# RULES
+"unsafeFreeze/STArray" unsafeFreeze = GHC.Arr.unsafeFreezeSTArray
+"unsafeFreeze/STUArray" unsafeFreeze = unsafeFreezeSTUArray
+ #-}
+
+-----------------------------------------------------------------------------
+-- Thawing
+
+thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+thaw arr | (l,u) <- bounds arr = do
+ marr <- newArray_ (l,u)
+ sequence_ [unsafeWrite marr i (unsafeAt arr i)
+ | i <- [0 .. rangeSize (l,u) - 1]]
+ return marr
+
+thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
+thawSTUArray (UArray l u arr#) = ST $ \s1# ->
+ case sizeofByteArray# arr# of { n# ->
+ case newByteArray# n# s1# of { (# s2#, marr# #) ->
+ case unsafeCoerce# memcpy marr# arr# n# s2# of { (# s3#, () #) ->
+ (# s3#, STUArray l u marr# #) }}}
+
+foreign import "memcpy" unsafe
+ memcpy :: MutableByteArray# RealWorld -> ByteArray# -> Int# -> IO ()
+
+{-# RULES
+"thaw/STArray" thaw = GHC.Arr.thawSTArray
+"thaw/STUArray" thaw = thawSTUArray
+ #-}
+
+-- In-place conversion of immutable arrays to mutable ones places
+-- a proof obligation on the user: no other parts of your code can
+-- have a reference to the array at the point where you unsafely
+-- thaw it (and, subsequently mutate it, I suspect).
+
+{-# INLINE unsafeThaw #-}
+unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+unsafeThaw = thaw
+
+{-# INLINE unsafeThawSTUArray #-}
+unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e)
+unsafeThawSTUArray (UArray l u marr#) =
+ return (STUArray l u (unsafeCoerce# marr#))
+
+{-# RULES
+"unsafeThaw/STArray" unsafeThaw = GHC.Arr.unsafeThawSTArray
+"unsafeThaw/STUArray" unsafeThaw = unsafeThawSTUArray
+ #-}
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.IArray
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: IArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Overloaded immutable array class.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.IArray (
+ module Data.Ix,
+
+ -- Class of immutable array types
+ IArray, -- :: (* -> * -> *) -> * -> class
+ -- Class of array types with immutable bounds
+ HasBounds, -- :: (* -> * -> *) -> class
+
+ array, -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e
+ listArray, -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e
+ (!), -- :: (IArray a e, Ix i) => a i e -> i -> e
+ bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i)
+ indices, -- :: (HasBounds a, Ix i) => a i e -> [i]
+ elems, -- :: (IArray a e, Ix i) => a i e -> [e]
+ assocs, -- :: (IArray a e, Ix i) => a i e -> [(i, e)]
+ accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e
+ (//), -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e
+ accum, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e
+ amap, -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e
+ ixmap) -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e
+ where
+
+import Prelude
+
+import Data.Ix
+import Data.Array.Base
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.IO
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: IO.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable boxed/unboxed arrays in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.IO (
+ module Data.Array.MArray,
+ IOArray, -- instance of: Eq, Typeable
+ IOUArray, -- instance of: Eq, Typeable
+ castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b)
+ ) where
+
+import Prelude
+
+import Data.Array ( Array )
+import Data.Array.MArray
+import Data.Int
+import Data.Word
+import Data.Dynamic
+
+import Foreign.Ptr ( Ptr, FunPtr )
+import Foreign.StablePtr ( StablePtr )
+
+#ifdef __GLASGOW_HASKELL__
+-- GHC only to the end of file
+
+import Data.Array.Base
+import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray,
+ thawSTArray, unsafeThawSTArray )
+
+import GHC.ST ( ST(..) )
+import GHC.IOBase ( stToIO )
+
+import GHC.Base
+
+-----------------------------------------------------------------------------
+-- Polymorphic non-strict mutable arrays (IO monad)
+
+newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq
+
+iOArrayTc :: TyCon
+iOArrayTc = mkTyCon "IOArray"
+
+instance (Typeable a, Typeable b) => Typeable (IOArray a b) where
+ typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a),
+ typeOf ((undefined :: IOArray a b -> b) a)]
+
+instance HasBounds IOArray where
+ {-# INLINE bounds #-}
+ bounds (IOArray marr) = bounds marr
+
+instance MArray IOArray e IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-----------------------------------------------------------------------------
+-- Flat unboxed mutable arrays (IO monad)
+
+newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq
+
+iOUArrayTc :: TyCon
+iOUArrayTc = mkTyCon "IOUArray"
+
+instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where
+ typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a),
+ typeOf ((undefined :: IOUArray a b -> b) a)]
+
+instance HasBounds IOUArray where
+ {-# INLINE bounds #-}
+ bounds (IOUArray marr) = bounds marr
+
+instance MArray IOUArray Bool IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Char IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (Ptr a) IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (FunPtr a) IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Float IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Double IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray (StablePtr a) IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int8 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int16 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int32 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Int64 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word8 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word16 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word32 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+instance MArray IOUArray Word64 IO where
+ {-# INLINE newArray #-}
+ newArray lu init = stToIO $ do
+ marr <- newArray lu init; return (IOUArray marr)
+ {-# INLINE newArray_ #-}
+ newArray_ lu = stToIO $ do
+ marr <- newArray_ lu; return (IOUArray marr)
+ {-# INLINE unsafeRead #-}
+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
+ {-# INLINE unsafeWrite #-}
+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)
+
+-----------------------------------------------------------------------------
+-- Freezing
+
+freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
+freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr)
+
+freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
+freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)
+
+{-# RULES
+"freeze/IOArray" freeze = freezeIOArray
+"freeze/IOUArray" freeze = freezeIOUArray
+ #-}
+
+{-# INLINE unsafeFreezeIOArray #-}
+unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e)
+unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr)
+
+{-# INLINE unsafeFreezeIOUArray #-}
+unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
+unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)
+
+{-# RULES
+"unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray
+"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
+ #-}
+
+-----------------------------------------------------------------------------
+-- Thawing
+
+thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
+thawIOArray arr = stToIO $ do
+ marr <- thawSTArray arr
+ return (IOArray marr)
+
+thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
+thawIOUArray arr = stToIO $ do
+ marr <- thawSTUArray arr
+ return (IOUArray marr)
+
+{-# RULES
+"thaw/IOArray" thaw = thawIOArray
+"thaw/IOUArray" thaw = thawIOUArray
+ #-}
+
+{-# INLINE unsafeThawIOArray #-}
+unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e)
+unsafeThawIOArray arr = stToIO $ do
+ marr <- unsafeThawSTArray arr
+ return (IOArray marr)
+
+{-# INLINE unsafeThawIOUArray #-}
+unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
+unsafeThawIOUArray arr = stToIO $ do
+ marr <- unsafeThawSTUArray arr
+ return (IOUArray marr)
+
+{-# RULES
+"unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray
+"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
+ #-}
+
+castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
+castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
+
+castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
+castIOUArray (IOUArray marr) = stToIO $ do
+ marr' <- castSTUArray marr
+ return (IOUArray marr')
+
+#endif /* __GLASGOW_HASKELL__ */
--- /dev/null
+{-# OPTIONS -monly-3-regs #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.MArray
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: MArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Class of mutable arrays, and operations on them.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.MArray (
+ module Data.Ix,
+
+ -- Class of mutable array types
+ MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class
+ -- Class of array types with immutable bounds
+ HasBounds, -- :: (* -> * -> *) -> class
+
+ newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e)
+ newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e)
+ newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e)
+ readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e
+ writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m ()
+ bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i)
+ indices, -- :: (HasBounds a, Ix i) => a i e -> [i]
+ getElems, -- :: (MArray a e m, Ix i) => a i e -> m [e]
+ getAssocs, -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)]
+ mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e)
+ mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e)
+
+ freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+ unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e)
+ thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+ unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e)
+ ) where
+
+import Prelude
+
+import Data.Ix
+import Data.Array.Base
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.ST
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable boxed/unboxed arrays in the ST monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.ST (
+ module Data.Array.MArray,
+ STArray, -- instance of: Eq, MArray
+ STUArray, -- instance of: Eq, MArray
+ castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b)
+ ) where
+
+import Prelude
+
+import Data.Array.MArray
+import Data.Array.Base
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr
+import GHC.ST
+
+castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b)
+castSTUArray (STUArray l u marr#) = return (STUArray l u marr#)
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Array.Unboxed
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Unboxed.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Unboxed immutable array type.
+--
+-----------------------------------------------------------------------------
+
+module Data.Array.Unboxed (
+ module Data.Array.IArray,
+ UArray,
+ ) where
+
+import Prelude
+
+import Data.Array.IArray
+import Data.Array.Base
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Bits
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Bits.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Bitwise operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Bits (
+ Bits(
+ (.&.), (.|.), xor, -- :: a -> a -> a
+ complement, -- :: a -> a
+ shift, -- :: a -> Int -> a
+ rotate, -- :: a -> Int -> a
+ bit, -- :: Int -> a
+ setBit, -- :: a -> Int -> a
+ clearBit, -- :: a -> Int -> a
+ complementBit, -- :: a -> Int -> a
+ testBit, -- :: a -> Int -> Bool
+ bitSize, -- :: a -> Int
+ isSigned -- :: a -> Bool
+ ),
+ shiftL, shiftR, -- :: Bits a => a -> Int -> a
+ rotateL, rotateR, -- :: Bits a => a -> Int -> a
+ -- instance Bits Int
+ -- instance Bits Integer
+ ) where
+
+-- Defines the @Bits@ class containing bit-based operations.
+-- See library document for details on the semantics of the
+-- individual operations.
+
+#ifdef __GLASGOW_HASKELL__
+#include "MachDeps.h"
+import GHC.Num
+import GHC.Real
+import GHC.Base
+#endif
+
+--ADR: The fixity for .|. conflicts with that for .|. in Fran.
+-- Removing all fixities is a fairly safe fix; fixing the "one fixity
+-- per symbol per program" limitation in Hugs would take a lot longer.
+#ifndef __HUGS__
+infixl 8 `shift`, `rotate`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.
+#endif
+
+class Num a => Bits a where
+ (.&.), (.|.), xor :: a -> a -> a
+ complement :: a -> a
+ shift :: a -> Int -> a
+ rotate :: a -> Int -> a
+ bit :: Int -> a
+ setBit :: a -> Int -> a
+ clearBit :: a -> Int -> a
+ complementBit :: a -> Int -> a
+ testBit :: a -> Int -> Bool
+ bitSize :: a -> Int
+ isSigned :: a -> Bool
+
+ bit i = 1 `shift` i
+ x `setBit` i = x .|. bit i
+ x `clearBit` i = x .&. complement (bit i)
+ x `complementBit` i = x `xor` bit i
+ x `testBit` i = (x .&. bit i) /= 0
+
+shiftL, shiftR :: Bits a => a -> Int -> a
+rotateL, rotateR :: Bits a => a -> Int -> a
+x `shiftL` i = x `shift` i
+x `shiftR` i = x `shift` (-i)
+x `rotateL` i = x `rotate` i
+x `rotateR` i = x `rotate` (-i)
+
+#ifdef __GLASGOW_HASKELL__
+instance Bits Int where
+ (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#))
+ (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#))
+ (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#))
+ complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#)))
+ (I# x#) `shift` (I# i#)
+ | i# >=# 0# = I# (x# `iShiftL#` i#)
+ | otherwise = I# (x# `iShiftRA#` negateInt# i#)
+ (I# x#) `rotate` (I# i#) =
+#if WORD_SIZE_IN_BYTES == 4
+ I# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (32# -# i'#))))
+ where
+ x'# = int2Word# x#
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
+#else
+ I# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (64# -# i'#))))
+ where
+ x'# = int2Word# x#
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
+#endif
+ bitSize _ = WORD_SIZE_IN_BYTES * 8
+ isSigned _ = True
+
+instance Bits Integer where
+ (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y))
+ x@(S# _) .&. y = toBig x .&. y
+ x .&. y@(S# _) = x .&. toBig y
+ (J# s1 d1) .&. (J# s2 d2) =
+ case andInteger# s1 d1 s2 d2 of
+ (# s, d #) -> J# s d
+
+ (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y))
+ x@(S# _) .|. y = toBig x .|. y
+ x .|. y@(S# _) = x .|. toBig y
+ (J# s1 d1) .|. (J# s2 d2) =
+ case orInteger# s1 d1 s2 d2 of
+ (# s, d #) -> J# s d
+
+ (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y))
+ x@(S# _) `xor` y = toBig x `xor` y
+ x `xor` y@(S# _) = x `xor` toBig y
+ (J# s1 d1) `xor` (J# s2 d2) =
+ case xorInteger# s1 d1 s2 d2 of
+ (# s, d #) -> J# s d
+
+ complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#)))
+ complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d
+
+ shift x i | i >= 0 = x * 2^i
+ | otherwise = x `div` 2^(-i)
+
+ rotate x i = shift x i -- since an Integer never wraps around
+
+ bitSize _ = error "Bits.bitSize(Integer)"
+ isSigned _ = True
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Bool
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Bool.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Bool type and related functions.
+--
+-----------------------------------------------------------------------------
+
+module Data.Bool (
+ Bool(..),
+ (&&), -- :: Bool -> Bool -> Bool
+ (||), -- :: Bool -> Bool -> Bool
+ not, -- :: Bool -> Bool
+ otherwise, -- :: Bool
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Char
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Char.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Char type and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Char
+ (
+ Char
+
+ , isAscii, isLatin1, isControl
+ , isPrint, isSpace, isUpper
+ , isLower, isAlpha, isDigit
+ , isOctDigit, isHexDigit, isAlphaNum -- :: Char -> Bool
+
+ , toUpper, toLower -- :: Char -> Char
+
+ , digitToInt -- :: Char -> Int
+ , intToDigit -- :: Int -> Char
+
+ , ord -- :: Char -> Int
+ , chr -- :: Int -> Char
+ , readLitChar -- :: ReadS Char
+ , showLitChar -- :: Char -> ShowS
+ , lexLitChar -- :: ReadS String
+
+ , String
+
+ -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Show
+import GHC.Read (readLitChar, lexLitChar, digitToInt)
+#endif
+
+#ifdef __HUGS__
+isLatin1 c = True
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Complex
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Complex.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Complex numbers.
+--
+-----------------------------------------------------------------------------
+
+module Data.Complex
+ ( Complex((:+))
+
+ , realPart -- :: (RealFloat a) => Complex a -> a
+ , imagPart -- :: (RealFloat a) => Complex a -> a
+ , conjugate -- :: (RealFloat a) => Complex a -> Complex a
+ , mkPolar -- :: (RealFloat a) => a -> a -> Complex a
+ , cis -- :: (RealFloat a) => a -> Complex a
+ , polar -- :: (RealFloat a) => Complex a -> (a,a)
+ , magnitude -- :: (RealFloat a) => Complex a -> a
+ , phase -- :: (RealFloat a) => Complex a -> a
+
+ -- Complex instances:
+ --
+ -- (RealFloat a) => Eq (Complex a)
+ -- (RealFloat a) => Read (Complex a)
+ -- (RealFloat a) => Show (Complex a)
+ -- (RealFloat a) => Num (Complex a)
+ -- (RealFloat a) => Fractional (Complex a)
+ -- (RealFloat a) => Floating (Complex a)
+ --
+ -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+
+ ) where
+
+import Prelude
+
+import Data.Dynamic
+
+infix 6 :+
+
+-- -----------------------------------------------------------------------------
+-- The Complex type
+
+data (RealFloat a) => Complex a = !a :+ !a deriving (Eq, Read, Show)
+
+
+-- -----------------------------------------------------------------------------
+-- Functions over Complex
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x :+ _) = x
+imagPart (_ :+ y) = y
+
+conjugate :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) = x :+ (-y)
+
+mkPolar :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta = r * cos theta :+ r * sin theta
+
+cis :: (RealFloat a) => a -> Complex a
+cis theta = cos theta :+ sin theta
+
+polar :: (RealFloat a) => Complex a -> (a,a)
+polar z = (magnitude z, phase z)
+
+magnitude :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) = scaleFloat k
+ (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int)))
+ where k = max (exponent x) (exponent y)
+ mk = - k
+
+phase :: (RealFloat a) => Complex a -> a
+phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson
+phase (x:+y) = atan2 y x
+
+
+-- -----------------------------------------------------------------------------
+-- Instances of Complex
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(Complex,complexTc,"Complex")
+
+instance (RealFloat a) => Num (Complex a) where
+ {-# SPECIALISE instance Num (Complex Float) #-}
+ {-# SPECIALISE instance Num (Complex Double) #-}
+ (x:+y) + (x':+y') = (x+x') :+ (y+y')
+ (x:+y) - (x':+y') = (x-x') :+ (y-y')
+ (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')
+ negate (x:+y) = negate x :+ negate y
+ abs z = magnitude z :+ 0
+ signum 0 = 0
+ signum z@(x:+y) = x/r :+ y/r where r = magnitude z
+ fromInteger n = fromInteger n :+ 0
+
+instance (RealFloat a) => Fractional (Complex a) where
+ {-# SPECIALISE instance Fractional (Complex Float) #-}
+ {-# SPECIALISE instance Fractional (Complex Double) #-}
+ (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+ where x'' = scaleFloat k x'
+ y'' = scaleFloat k y'
+ k = - max (exponent x') (exponent y')
+ d = x'*x'' + y'*y''
+
+ fromRational a = fromRational a :+ 0
+
+instance (RealFloat a) => Floating (Complex a) where
+ {-# SPECIALISE instance Floating (Complex Float) #-}
+ {-# SPECIALISE instance Floating (Complex Double) #-}
+ pi = pi :+ 0
+ exp (x:+y) = expx * cos y :+ expx * sin y
+ where expx = exp x
+ log z = log (magnitude z) :+ phase z
+
+ sqrt 0 = 0
+ sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
+ where (u,v) = if x < 0 then (v',u') else (u',v')
+ v' = abs y / (u'*2)
+ u' = sqrt ((magnitude z + abs x) / 2)
+
+ sin (x:+y) = sin x * cosh y :+ cos x * sinh y
+ cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y)
+ tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+ where sinx = sin x
+ cosx = cos x
+ sinhy = sinh y
+ coshy = cosh y
+
+ sinh (x:+y) = cos y * sinh x :+ sin y * cosh x
+ cosh (x:+y) = cos y * cosh x :+ sin y * sinh x
+ tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+ where siny = sin y
+ cosy = cos y
+ sinhx = sinh x
+ coshx = cosh x
+
+ asin z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+ acos z = y'':+(-x'')
+ where (x'':+y'') = log (z + ((-y'):+x'))
+ (x':+y') = sqrt (1 - z*z)
+ atan z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+
+ asinh z = log (z + sqrt (1+z*z))
+ acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))
+ atanh z = log ((1+z) / sqrt (1-z*z))
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Dynamic
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Dynamic.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Dynamic interface provides basic support for dynamic types.
+--
+-- Operations for injecting values of arbitrary type into
+-- a dynamically typed value, Dynamic, are provided, together
+-- with operations for converting dynamic values into a concrete
+-- (monomorphic) type.
+--
+-- The Dynamic implementation provided is closely based on code
+-- contained in Hugs library of the same name.
+--
+-----------------------------------------------------------------------------
+
+module Data.Dynamic
+ (
+ -- dynamic type
+ Dynamic -- abstract, instance of: Show, Typeable
+ , toDyn -- :: Typeable a => a -> Dynamic
+ , fromDyn -- :: Typeable a => Dynamic -> a -> a
+ , fromDynamic -- :: Typeable a => Dynamic -> Maybe a
+
+ -- type representation
+
+ , Typeable(
+ typeOf) -- :: a -> TypeRep
+
+ -- Dynamic defines Typeable instances for the following
+ -- Prelude types: [a], (), (a,b), (a,b,c), (a,b,c,d),
+ -- (a,b,c,d,e), (a->b), (Array a b), Bool, Char,
+ -- (Complex a), Double, (Either a b), Float, Handle,
+ -- Int, Integer, (IO a), (Maybe a), Ordering
+
+ , TypeRep -- abstract, instance of: Eq, Show, Typeable
+ , TyCon -- abstract, instance of: Eq, Show, Typeable
+
+ -- type representation constructors/operators:
+ , mkTyCon -- :: String -> TyCon
+ , mkAppTy -- :: TyCon -> [TypeRep] -> TypeRep
+ , mkFunTy -- :: TypeRep -> TypeRep -> TypeRep
+ , applyTy -- :: TypeRep -> TypeRep -> Maybe TypeRep
+
+ --
+ -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
+ -- [fTy,fTy,fTy])
+ --
+ -- returns "(Foo,Foo,Foo)"
+ --
+ -- The TypeRep Show instance promises to print tuple types
+ -- correctly. Tuple type constructors are specified by a
+ -- sequence of commas, e.g., (mkTyCon ",,,,") returns
+ -- the 5-tuple tycon.
+ ) where
+
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Maybe
+import GHC.Show
+import GHC.Err
+import GHC.Num
+import GHC.Float
+import GHC.IOBase
+import GHC.Dynamic
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Prim ( unsafeCoerce# )
+
+unsafeCoerce :: a -> b
+unsafeCoerce = unsafeCoerce#
+#endif
+
+#include "Dynamic.h"
+
+-- The dynamic type is represented by Dynamic, carrying
+-- the dynamic value along with its type representation:
+
+-- the instance just prints the type representation.
+instance Show Dynamic where
+ showsPrec _ (Dynamic t _) =
+ showString "<<" .
+ showsPrec 0 t .
+ showString ">>"
+
+-- Operations for going to and from Dynamic:
+
+toDyn :: Typeable a => a -> Dynamic
+toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
+
+fromDyn :: Typeable a => Dynamic -> a -> a
+fromDyn (Dynamic t v) def
+ | typeOf def == t = unsafeCoerce v
+ | otherwise = def
+
+fromDynamic :: Typeable a => Dynamic -> Maybe a
+fromDynamic (Dynamic t v) =
+ case unsafeCoerce v of
+ r | t == typeOf r -> Just r
+ | otherwise -> Nothing
+
+-- (Abstract) universal datatype:
+
+instance Show TypeRep where
+ showsPrec p (App tycon tys) =
+ case tys of
+ [] -> showsPrec p tycon
+ [x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
+ xs
+ | isTupleTyCon tycon -> showTuple tycon xs
+ | otherwise ->
+ showParen (p > 9) $
+ showsPrec p tycon .
+ showChar ' ' .
+ showArgs tys
+
+ showsPrec p (Fun f a) =
+ showParen (p > 8) $
+ showsPrec 9 f . showString " -> " . showsPrec 8 a
+
+-- To make it possible to convert values with user-defined types
+-- into type Dynamic, we need a systematic way of getting
+-- the type representation of an arbitrary type. A type
+-- class provides just the ticket,
+
+class Typeable a where
+ typeOf :: a -> TypeRep
+
+-- NOTE: The argument to the overloaded `typeOf' is only
+-- used to carry type information, and Typeable instances
+-- should *never* *ever* look at its value.
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ (',':_)) = True
+isTupleTyCon _ = False
+
+instance Show TyCon where
+ showsPrec _ (TyCon _ s) = showString s
+
+-- If we enforce the restriction that there is only one
+-- @TyCon@ for a type & it is shared among all its uses,
+-- we can map them onto Ints very simply. The benefit is,
+-- of course, that @TyCon@s can then be compared efficiently.
+
+-- Provided the implementor of other @Typeable@ instances
+-- takes care of making all the @TyCon@s CAFs (toplevel constants),
+-- this will work.
+
+-- If this constraint does turn out to be a sore thumb, changing
+-- the Eq instance for TyCons is trivial.
+
+mkTyCon :: String -> TyCon
+mkTyCon str = unsafePerformIO $ do
+ v <- readIORef uni
+ writeIORef uni (v+1)
+ return (TyCon v str)
+
+{-# NOINLINE uni #-}
+uni :: IORef Int
+uni = unsafePerformIO ( newIORef 0 )
+
+-- Some (Show.TypeRep) helpers:
+
+showArgs :: Show a => [a] -> ShowS
+showArgs [] = id
+showArgs [a] = showsPrec 10 a
+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
+
+showTuple :: TyCon -> [TypeRep] -> ShowS
+showTuple (TyCon _ str) args = showChar '(' . go str args
+ where
+ go [] [a] = showsPrec 10 a . showChar ')'
+ go _ [] = showChar ')' -- a failure condition, really.
+ go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
+ go _ _ = showChar ')'
+
+
+mkAppTy :: TyCon -> [TypeRep] -> TypeRep
+mkAppTy tyc args = App tyc args
+
+mkFunTy :: TypeRep -> TypeRep -> TypeRep
+mkFunTy f a = Fun f a
+
+-- Auxillary functions
+
+-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
+dynApply (Dynamic t1 f) (Dynamic t2 x) =
+ case applyTy t1 t2 of
+ Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
+ Nothing -> Nothing
+
+dynApp :: Dynamic -> Dynamic -> Dynamic
+dynApp f x = case dynApply f x of
+ Just r -> r
+ Nothing -> error ("Type error in dynamic application.\n" ++
+ "Can't apply function " ++ show f ++
+ " to argument " ++ show x)
+
+applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
+applyTy (Fun t1 t2) t3
+ | t1 == t3 = Just t2
+applyTy _ _ = Nothing
+
+-- Prelude types
+
+listTc :: TyCon
+listTc = mkTyCon "[]"
+
+instance Typeable a => Typeable [a] where
+ typeOf ls = mkAppTy listTc [typeOf ((undefined:: [a] -> a) ls)]
+
+unitTc :: TyCon
+unitTc = mkTyCon "()"
+
+instance Typeable () where
+ typeOf _ = mkAppTy unitTc []
+
+tup2Tc :: TyCon
+tup2Tc = mkTyCon ","
+
+instance (Typeable a, Typeable b) => Typeable (a,b) where
+ typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
+ typeOf ((undefined :: (a,b) -> b) tu)]
+
+tup3Tc :: TyCon
+tup3Tc = mkTyCon ",,"
+
+instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
+ typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
+ typeOf ((undefined :: (a,b,c) -> b) tu),
+ typeOf ((undefined :: (a,b,c) -> c) tu)]
+
+tup4Tc :: TyCon
+tup4Tc = mkTyCon ",,,"
+
+instance ( Typeable a
+ , Typeable b
+ , Typeable c
+ , Typeable d) => Typeable (a,b,c,d) where
+ typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
+ typeOf ((undefined :: (a,b,c,d) -> b) tu),
+ typeOf ((undefined :: (a,b,c,d) -> c) tu),
+ typeOf ((undefined :: (a,b,c,d) -> d) tu)]
+
+tup5Tc :: TyCon
+tup5Tc = mkTyCon ",,,,"
+
+instance ( Typeable a
+ , Typeable b
+ , Typeable c
+ , Typeable d
+ , Typeable e) => Typeable (a,b,c,d,e) where
+ typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
+ typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
+
+instance (Typeable a, Typeable b) => Typeable (a -> b) where
+ typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
+ (typeOf ((undefined :: (a -> b) -> b) f))
+
+INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
+INSTANCE_TYPEABLE0(Char,charTc,"Char")
+INSTANCE_TYPEABLE0(Float,floatTc,"Float")
+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
+INSTANCE_TYPEABLE0(Int,intTc,"Int")
+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
+INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
+INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Either
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Either.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Either type, and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Either (
+ Either(..),
+ either -- :: (a -> c) -> (b -> c) -> Either a b -> c
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Maybe
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.IORef
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: IORef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable references in the IO monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.IORef
+ ( IORef -- abstract, instance of: Eq, Typeable
+ , newIORef -- :: a -> IO (IORef a)
+ , readIORef -- :: IORef a -> IO a
+ , writeIORef -- :: IORef a -> a -> IO ()
+ , modifyIORef -- :: IORef a -> (a -> a) -> IO ()
+
+#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__)
+ , mkWeakIORef -- :: IORef a -> IO () -> IO (Weak (IORef a))
+#endif
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Prim ( mkWeak# )
+import GHC.STRef
+import GHC.IOBase
+#if !defined(__PARALLEL_HASKELL__)
+import GHC.Weak
+#endif
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifdef __HUGS__
+import IOExts ( IORef, newIORef, writeIORef, readIORef )
+import ST ( stToIO, newSTRef, readSTRef, writeSTRef )
+#endif
+
+import Data.Dynamic
+
+#ifndef __PARALLEL_HASKELL__
+mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a))
+mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s ->
+ case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #)
+#endif
+
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = writeIORef ref . f =<< readIORef ref
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Int
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Int.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sized Integer types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Int
+ ( Int8
+ , Int16
+ , Int32
+ , Int64
+ -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
+ -- Show, Bits, CCallable, CReturnable (last two are GHC specific.)
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Int
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Int8,int8Tc, "Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Ix
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Ix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Class of index types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Ix
+ (
+ Ix
+ ( range -- :: (Ix a) => (a,a) -> [a]
+ , index -- :: (Ix a) => (a,a) -> a -> Int
+ , inRange -- :: (Ix a) => (a,a) -> a -> Bool
+ )
+ , rangeSize -- :: (Ix a) => (a,a) -> Int
+ -- Ix instances:
+ --
+ -- Ix Char
+ -- Ix Int
+ -- Ix Integer
+ -- Ix Bool
+ -- Ix Ordering
+ -- Ix ()
+ -- (Ix a, Ix b) => Ix (a, b)
+ -- ...
+
+ -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Arr
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.List
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Operations on lists.
+--
+-----------------------------------------------------------------------------
+
+module Data.List
+ (
+ [] (..),
+
+ , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int
+ , elemIndices -- :: (Eq a) => a -> [a] -> [Int]
+
+ , find -- :: (a -> Bool) -> [a] -> Maybe a
+ , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int
+ , findIndices -- :: (a -> Bool) -> [a] -> [Int]
+
+ , nub -- :: (Eq a) => [a] -> [a]
+ , nubBy -- :: (a -> a -> Bool) -> [a] -> [a]
+
+ , delete -- :: (Eq a) => a -> [a] -> [a]
+ , deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a]
+ , (\\) -- :: (Eq a) => [a] -> [a] -> [a]
+ , deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+
+ , union -- :: (Eq a) => [a] -> [a] -> [a]
+ , unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+
+ , intersect -- :: (Eq a) => [a] -> [a] -> [a]
+ , intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+
+ , intersperse -- :: a -> [a] -> [a]
+ , transpose -- :: [[a]] -> [[a]]
+ , partition -- :: (a -> Bool) -> [a] -> ([a], [a])
+
+ , group -- :: Eq a => [a] -> [[a]]
+ , groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]]
+
+ , inits -- :: [a] -> [[a]]
+ , tails -- :: [a] -> [[a]]
+
+ , isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool
+ , isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool
+
+ , mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
+ , mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c])
+
+ , sort -- :: (Ord a) => [a] -> [a]
+ , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a]
+
+ , insert -- :: (Ord a) => a -> [a] -> [a]
+ , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a]
+
+ , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a
+ , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a
+
+ , genericLength -- :: (Integral a) => [b] -> a
+ , genericTake -- :: (Integral a) => a -> [b] -> [b]
+ , genericDrop -- :: (Integral a) => a -> [b] -> [b]
+ , genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b])
+ , genericIndex -- :: (Integral a) => [b] -> a -> b
+ , genericReplicate -- :: (Integral a) => a -> b -> [b]
+
+ , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a]
+
+ , zip4, zip5, zip6, zip7
+ , zipWith4, zipWith5, zipWith6, zipWith7
+ , unzip4, unzip5, unzip6, unzip7
+
+ , map -- :: ( a -> b ) -> [a] -> [b]
+ , (++) -- :: [a] -> [a] -> [a]
+ , concat -- :: [[a]] -> [a]
+ , filter -- :: (a -> Bool) -> [a] -> [a]
+ , head -- :: [a] -> a
+ , last -- :: [a] -> a
+ , tail -- :: [a] -> [a]
+ , init -- :: [a] -> [a]
+ , null -- :: [a] -> Bool
+ , length -- :: [a] -> Int
+ , (!!) -- :: [a] -> Int -> a
+ , foldl -- :: (a -> b -> a) -> a -> [b] -> a
+ , foldl1 -- :: (a -> a -> a) -> [a] -> a
+ , scanl -- :: (a -> b -> a) -> a -> [b] -> [a]
+ , scanl1 -- :: (a -> a -> a) -> [a] -> [a]
+ , foldr -- :: (a -> b -> b) -> b -> [a] -> b
+ , foldr1 -- :: (a -> a -> a) -> [a] -> a
+ , scanr -- :: (a -> b -> b) -> b -> [a] -> [b]
+ , scanr1 -- :: (a -> a -> a) -> [a] -> [a]
+ , iterate -- :: (a -> a) -> a -> [a]
+ , repeat -- :: a -> [a]
+ , replicate -- :: Int -> a -> [a]
+ , cycle -- :: [a] -> [a]
+ , take -- :: Int -> [a] -> [a]
+ , drop -- :: Int -> [a] -> [a]
+ , splitAt -- :: Int -> [a] -> ([a], [a])
+ , takeWhile -- :: (a -> Bool) -> [a] -> [a]
+ , dropWhile -- :: (a -> Bool) -> [a] -> [a]
+ , span -- :: (a -> Bool) -> [a] -> ([a], [a])
+ , break -- :: (a -> Bool) -> [a] -> ([a], [a])
+
+ , lines -- :: String -> [String]
+ , words -- :: String -> [String]
+ , unlines -- :: [String] -> String
+ , unwords -- :: [String] -> String
+ , reverse -- :: [a] -> [a]
+ , and -- :: [Bool] -> Bool
+ , or -- :: [Bool] -> Bool
+ , any -- :: (a -> Bool) -> [a] -> Bool
+ , all -- :: (a -> Bool) -> [a] -> Bool
+ , elem -- :: a -> [a] -> Bool
+ , notElem -- :: a -> [a] -> Bool
+ , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b
+ , sum -- :: (Num a) => [a] -> a
+ , product -- :: (Num a) => [a] -> a
+ , maximum -- :: (Ord a) => [a] -> a
+ , minimum -- :: (Ord a) => [a] -> a
+ , concatMap -- :: (a -> [b]) -> [a] -> [b]
+ , zip -- :: [a] -> [b] -> [(a,b)]
+ , zip3
+ , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c]
+ , zipWith3
+ , unzip -- :: [(a,b)] -> ([a],[b])
+ , unzip3
+
+ ) where
+
+import Data.Maybe
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Num
+import GHC.Real
+import GHC.List
+import GHC.Show ( lines, words, unlines, unwords )
+import GHC.Base
+#endif
+
+infix 5 \\
+
+-- -----------------------------------------------------------------------------
+-- List functions
+
+elemIndex :: Eq a => a -> [a] -> Maybe Int
+elemIndex x = findIndex (x==)
+
+elemIndices :: Eq a => a -> [a] -> [Int]
+elemIndices x = findIndices (x==)
+
+find :: (a -> Bool) -> [a] -> Maybe a
+find p = listToMaybe . filter p
+
+findIndex :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p = listToMaybe . findIndices p
+
+findIndices :: (a -> Bool) -> [a] -> [Int]
+
+#ifdef USE_REPORT_PRELUDE
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
+#else
+#ifdef __HUGS__
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x]
+#else
+-- Efficient definition
+findIndices p ls = loop 0# ls
+ where
+ loop _ [] = []
+ loop n (x:xs) | p x = I# n : loop (n +# 1#) xs
+ | otherwise = loop (n +# 1#) xs
+#endif /* __HUGS__ */
+#endif /* USE_REPORT_PRELUDE */
+
+isPrefixOf :: (Eq a) => [a] -> [a] -> Bool
+isPrefixOf [] _ = True
+isPrefixOf _ [] = False
+isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys
+
+isSuffixOf :: (Eq a) => [a] -> [a] -> Bool
+isSuffixOf x y = reverse x `isPrefixOf` reverse y
+
+-- nub (meaning "essence") remove duplicate elements from its list argument.
+nub :: (Eq a) => [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+nub = nubBy (==)
+#else
+-- stolen from HBC
+nub l = nub' l [] -- '
+ where
+ nub' [] _ = [] -- '
+ nub' (x:xs) ls -- '
+ | x `elem` ls = nub' xs ls -- '
+ | otherwise = x : nub' xs (x:ls) -- '
+#endif
+
+nubBy :: (a -> a -> Bool) -> [a] -> [a]
+#ifdef USE_REPORT_PRELUDE
+nubBy eq [] = []
+nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs)
+#else
+nubBy eq l = nubBy' l []
+ where
+ nubBy' [] _ = []
+ nubBy' (y:ys) xs
+ | elem_by eq y xs = nubBy' ys xs
+ | otherwise = y : nubBy' ys (y:xs)
+
+-- Not exported:
+-- Note that we keep the call to `eq` with arguments in the
+-- same order as in the reference implementation
+-- 'xs' is the list of things we've seen so far,
+-- 'y' is the potential new element
+elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool
+elem_by _ _ [] = False
+elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs
+#endif
+
+
+-- delete x removes the first occurrence of x from its list argument.
+delete :: (Eq a) => a -> [a] -> [a]
+delete = deleteBy (==)
+
+deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy _ _ [] = []
+deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys
+
+-- list difference (non-associative). In the result of xs \\ ys,
+-- the first occurrence of each element of ys in turn (if any)
+-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys.
+(\\) :: (Eq a) => [a] -> [a] -> [a]
+(\\) = foldl (flip delete)
+
+-- List union, remove the elements of first list from second.
+union :: (Eq a) => [a] -> [a] -> [a]
+union = unionBy (==)
+
+unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
+
+intersect :: (Eq a) => [a] -> [a] -> [a]
+intersect = intersectBy (==)
+
+intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]
+
+-- intersperse sep inserts sep between the elements of its list argument.
+-- e.g. intersperse ',' "abcde" == "a,b,c,d,e"
+intersperse :: a -> [a] -> [a]
+intersperse _ [] = []
+intersperse _ [x] = [x]
+intersperse sep (x:xs) = x : sep : intersperse sep xs
+
+transpose :: [[a]] -> [[a]]
+transpose [] = []
+transpose ([] : xss) = transpose xss
+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss])
+
+
+-- partition takes a predicate and a list and returns a pair of lists:
+-- those elements of the argument list that do and do not satisfy the
+-- predicate, respectively; i,e,,
+-- partition p xs == (filter p xs, filter (not . p) xs).
+partition :: (a -> Bool) -> [a] -> ([a],[a])
+{-# INLINE partition #-}
+partition p xs = foldr (select p) ([],[]) xs
+
+select p x (ts,fs) | p x = (x:ts,fs)
+ | otherwise = (ts, x:fs)
+
+-- @mapAccumL@ behaves like a combination
+-- of @map@ and @foldl@;
+-- it applies a function to each element of a list, passing an accumulating
+-- parameter from left to right, and returning a final value of this
+-- accumulator together with the new list.
+
+mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
+ -- and accumulator, returning new
+ -- accumulator and elt of result list
+ -> acc -- Initial accumulator
+ -> [x] -- Input list
+ -> (acc, [y]) -- Final accumulator and result list
+mapAccumL _ s [] = (s, [])
+mapAccumL f s (x:xs) = (s'',y:ys)
+ where (s', y ) = f s x
+ (s'',ys) = mapAccumL f s' xs
+
+-- @mapAccumR@ does the same, but working from right to left instead.
+-- Its type is the same as @mapAccumL@, though.
+
+mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
+ -- and accumulator, returning new
+ -- accumulator and elt of result list
+ -> acc -- Initial accumulator
+ -> [x] -- Input list
+ -> (acc, [y]) -- Final accumulator and result list
+mapAccumR _ s [] = (s, [])
+mapAccumR f s (x:xs) = (s'', y:ys)
+ where (s'',y ) = f s' x
+ (s', ys) = mapAccumR f s xs
+
+
+insert :: Ord a => a -> [a] -> [a]
+insert e ls = insertBy (compare) e ls
+
+insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
+insertBy _ x [] = [x]
+insertBy cmp x ys@(y:ys')
+ = case cmp x y of
+ GT -> y : insertBy cmp x ys'
+ _ -> x : ys
+
+maximumBy :: (a -> a -> a) -> [a] -> a
+maximumBy _ [] = error "List.maximumBy: empty list"
+maximumBy max xs = foldl1 max xs
+
+minimumBy :: (a -> a -> a) -> [a] -> a
+minimumBy _ [] = error "List.minimumBy: empty list"
+minimumBy min xs = foldl1 min xs
+
+genericLength :: (Num i) => [b] -> i
+genericLength [] = 0
+genericLength (_:l) = 1 + genericLength l
+
+genericTake :: (Integral i) => i -> [a] -> [a]
+genericTake 0 _ = []
+genericTake _ [] = []
+genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs
+genericTake _ _ = error "List.genericTake: negative argument"
+
+genericDrop :: (Integral i) => i -> [a] -> [a]
+genericDrop 0 xs = xs
+genericDrop _ [] = []
+genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs
+genericDrop _ _ = error "List.genericDrop: negative argument"
+
+genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b])
+genericSplitAt 0 xs = ([],xs)
+genericSplitAt _ [] = ([],[])
+genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where
+ (xs',xs'') = genericSplitAt (n-1) xs
+genericSplitAt _ _ = error "List.genericSplitAt: negative argument"
+
+
+genericIndex :: (Integral a) => [b] -> a -> b
+genericIndex (x:_) 0 = x
+genericIndex (_:xs) n
+ | n > 0 = genericIndex xs (n-1)
+ | otherwise = error "List.genericIndex: negative argument."
+genericIndex _ _ = error "List.genericIndex: index too large."
+
+genericReplicate :: (Integral i) => i -> a -> [a]
+genericReplicate n x = genericTake n (repeat x)
+
+
+zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4 = zipWith4 (,,,)
+
+zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5 = zipWith5 (,,,,)
+
+zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [(a,b,c,d,e,f)]
+zip6 = zipWith6 (,,,,,)
+
+zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [g] -> [(a,b,c,d,e,f,g)]
+zip7 = zipWith7 (,,,,,,)
+
+zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+ = z a b c d : zipWith4 z as bs cs ds
+zipWith4 _ _ _ _ _ = []
+
+zipWith5 :: (a->b->c->d->e->f) ->
+ [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+ = z a b c d e : zipWith5 z as bs cs ds es
+zipWith5 _ _ _ _ _ _ = []
+
+zipWith6 :: (a->b->c->d->e->f->g) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+ = z a b c d e f : zipWith6 z as bs cs ds es fs
+zipWith6 _ _ _ _ _ _ _ = []
+
+zipWith7 :: (a->b->c->d->e->f->g->h) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+ = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+zipWith7 _ _ _ _ _ _ _ _ = []
+
+unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+ (a:as,b:bs,c:cs,d:ds))
+ ([],[],[],[])
+
+unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+ (a:as,b:bs,c:cs,d:ds,e:es))
+ ([],[],[],[],[])
+
+unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+ ([],[],[],[],[],[])
+
+unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+ ([],[],[],[],[],[],[])
+
+
+
+deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteFirstsBy eq = foldl (flip (deleteBy eq))
+
+
+-- group splits its list argument into a list of lists of equal, adjacent
+-- elements. e.g.,
+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
+group :: (Eq a) => [a] -> [[a]]
+group = groupBy (==)
+
+groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
+groupBy _ [] = []
+groupBy eq (x:xs) = (x:ys) : groupBy eq zs
+ where (ys,zs) = span (eq x) xs
+
+-- inits xs returns the list of initial segments of xs, shortest first.
+-- e.g., inits "abc" == ["","a","ab","abc"]
+inits :: [a] -> [[a]]
+inits [] = [[]]
+inits (x:xs) = [[]] ++ map (x:) (inits xs)
+
+-- tails xs returns the list of all final segments of xs, longest first.
+-- e.g., tails "abc" == ["abc", "bc", "c",""]
+tails :: [a] -> [[a]]
+tails [] = [[]]
+tails xxs@(_:xs) = xxs : tails xs
+
+
+------------------------------------------------------------------------------
+-- Quick Sort algorithm taken from HBC's QSort library.
+
+sort :: (Ord a) => [a] -> [a]
+sortBy :: (a -> a -> Ordering) -> [a] -> [a]
+
+#ifdef USE_REPORT_PRELUDE
+sort = sortBy compare
+sortBy cmp = foldr (insertBy cmp) []
+#else
+
+sortBy cmp l = qsort cmp l []
+sort l = qsort compare l []
+
+-- rest is not exported:
+
+-- qsort is stable and does not concatenate.
+qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+qsort _ [] r = r
+qsort _ [x] r = x:r
+qsort cmp (x:xs) r = qpart cmp x xs [] [] r
+
+-- qpart partitions and sorts the sublists
+qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
+qpart cmp x [] rlt rge r =
+ -- rlt and rge are in reverse order and must be sorted with an
+ -- anti-stable sorting
+ rqsort cmp rlt (x:rqsort cmp rge r)
+qpart cmp x (y:ys) rlt rge r =
+ case cmp x y of
+ GT -> qpart cmp x ys (y:rlt) rge r
+ _ -> qpart cmp x ys rlt (y:rge) r
+
+-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
+rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
+rqsort _ [] r = r
+rqsort _ [x] r = x:r
+rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r
+
+rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a]
+rqpart cmp x [] rle rgt r =
+ qsort cmp rle (x:qsort cmp rgt r)
+rqpart cmp x (y:ys) rle rgt r =
+ case cmp y x of
+ GT -> rqpart cmp x ys rle (y:rgt) r
+ _ -> rqpart cmp x ys (y:rle) rgt r
+
+#endif /* USE_REPORT_PRELUDE */
+
+{-
+\begin{verbatim}
+ unfoldr f' (foldr f z xs) == (z,xs)
+
+ if the following holds:
+
+ f' (f x y) = Just (x,y)
+ f' z = Nothing
+\end{verbatim}
+-}
+
+unfoldr :: (b -> Maybe (a, b)) -> b -> [a]
+unfoldr f b =
+ case f b of
+ Just (a,new_b) -> a : unfoldr f new_b
+ Nothing -> []
+
+-- -----------------------------------------------------------------------------
+-- List sum and product
+
+-- sum and product compute the sum or product of a finite list of numbers.
+{-# SPECIALISE sum :: [Int] -> Int #-}
+{-# SPECIALISE sum :: [Integer] -> Integer #-}
+{-# SPECIALISE product :: [Int] -> Int #-}
+{-# SPECIALISE product :: [Integer] -> Integer #-}
+sum, product :: (Num a) => [a] -> a
+#ifdef USE_REPORT_PRELUDE
+sum = foldl (+) 0
+product = foldl (*) 1
+#else
+sum l = sum' l 0
+ where
+ sum' [] a = a
+ sum' (x:xs) a = sum' xs (a+x)
+product l = prod l 1
+ where
+ prod [] a = a
+ prod (x:xs) a = prod xs (a*x)
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Maybe
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Maybe.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The Maybe type, and associated operations.
+--
+-----------------------------------------------------------------------------
+
+module Data.Maybe
+ (
+ Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read,
+ -- Functor, Monad, MonadPlus
+
+ , maybe -- :: b -> (a -> b) -> Maybe a -> b
+
+ , isJust -- :: Maybe a -> Bool
+ , isNothing -- :: Maybe a -> Bool
+ , fromJust -- :: Maybe a -> a
+ , fromMaybe -- :: a -> Maybe a -> a
+ , listToMaybe -- :: [a] -> Maybe a
+ , maybeToList -- :: Maybe a -> [a]
+ , catMaybes -- :: [Maybe a] -> [a]
+ , mapMaybe -- :: (a -> Maybe b) -> [a] -> [b]
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Err ( error )
+import GHC.List
+import GHC.Maybe
+import GHC.Base
+#endif
+
+isJust :: Maybe a -> Bool
+isJust Nothing = False
+isJust _ = True
+
+isNothing :: Maybe a -> Bool
+isNothing Nothing = True
+isNothing _ = False
+
+fromJust :: Maybe a -> a
+fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck
+fromJust (Just x) = x
+
+fromMaybe :: a -> Maybe a -> a
+fromMaybe d x = case x of {Nothing -> d;Just v -> v}
+
+maybeToList :: Maybe a -> [a]
+maybeToList Nothing = []
+maybeToList (Just x) = [x]
+
+listToMaybe :: [a] -> Maybe a
+listToMaybe [] = Nothing
+listToMaybe (a:_) = Just a
+
+catMaybes :: [Maybe a] -> [a]
+catMaybes ls = [x | Just x <- ls]
+
+mapMaybe :: (a -> Maybe b) -> [a] -> [b]
+mapMaybe _ [] = []
+mapMaybe f (x:xs) =
+ let rs = mapMaybe f xs in
+ case f x of
+ Nothing -> rs
+ Just r -> r:rs
+
--- /dev/null
+{-# OPTIONS -#include "PackedString.h" #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Data.PackedString
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: PackedString.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The PackedString type, and associated operations.
+-- GHC implementation by Bryan O'Sullivan.
+--
+-----------------------------------------------------------------------------
+
+module Data.PackedString (
+ PackedString, -- abstract, instances: Eq, Ord, Show, Typeable
+
+ -- Creating the beasts
+ packString, -- :: [Char] -> PackedString
+ packStringST, -- :: [Char] -> ST s PackedString
+ packCBytesST, -- :: Int -> Ptr a -> ST s PackedString
+
+ byteArrayToPS, -- :: ByteArray Int -> PackedString
+ cByteArrayToPS, -- :: ByteArray Int -> PackedString
+ unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
+
+ psToByteArray, -- :: PackedString -> ByteArray Int
+ psToCString, -- :: PackedString -> Ptr a
+ isCString, -- :: PackedString -> Bool
+
+ unpackPS, -- :: PackedString -> [Char]
+ unpackNBytesPS, -- :: PackedString -> Int -> [Char]
+ unpackPSIO, -- :: PackedString -> IO [Char]
+
+ hPutPS, -- :: Handle -> PackedString -> IO ()
+ hGetPS, -- :: Handle -> Int -> IO PackedString
+
+ nilPS, -- :: PackedString
+ consPS, -- :: Char -> PackedString -> PackedString
+ headPS, -- :: PackedString -> Char
+ tailPS, -- :: PackedString -> PackedString
+ nullPS, -- :: PackedString -> Bool
+ appendPS, -- :: PackedString -> PackedString -> PackedString
+ lengthPS, -- :: PackedString -> Int
+ {- 0-origin indexing into the string -}
+ indexPS, -- :: PackedString -> Int -> Char
+ mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
+ filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
+ foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
+ takePS, -- :: Int -> PackedString -> PackedString
+ dropPS, -- :: Int -> PackedString -> PackedString
+ splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
+ takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+ breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+ linesPS, -- :: PackedString -> [PackedString]
+
+ wordsPS, -- :: PackedString -> [PackedString]
+ reversePS, -- :: PackedString -> PackedString
+ splitPS, -- :: Char -> PackedString -> [PackedString]
+ splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
+ joinPS, -- :: PackedString -> [PackedString] -> PackedString
+ concatPS, -- :: [PackedString] -> PackedString
+ elemPS, -- :: Char -> PackedString -> Bool
+
+ {-
+ Pluck out a piece of a PS start and end
+ chars you want; both 0-origin-specified
+ -}
+ substrPS, -- :: PackedString -> Int -> Int -> PackedString
+
+ comparePS -- :: PackedString -> PackedString -> Ordering
+
+ ) where
+
+import Prelude
+
+import Foreign
+import Foreign.C
+
+import GHC.Prim
+import GHC.Base
+import GHC.ST
+import GHC.ByteArr
+
+import GHC.Show ( showList__ ) -- ToDo: better
+import GHC.Pack ( new_ps_array, freeze_ps_array, write_ps_array )
+
+import Control.Monad.ST
+
+import System.IO
+import System.IO.Unsafe ( unsafePerformIO )
+import GHC.IO ( hPutBufBA, hGetBufBA )
+
+import Data.Ix
+import Data.Char ( isSpace )
+import Data.Dynamic
+
+-- -----------------------------------------------------------------------------
+-- PackedString type declaration
+
+data PackedString
+ = PS ByteArray# -- the bytes
+ Int# -- length (*not* including NUL at the end)
+ Bool -- True <=> contains a NUL
+ | CPS Addr# -- pointer to the (null-terminated) bytes in C land
+ Int# -- length, as per strlen
+ -- definitely doesn't contain a NUL
+
+instance Eq PackedString where
+ x == y = compare x y == EQ
+ x /= y = compare x y /= EQ
+
+instance Ord PackedString where
+ compare = comparePS
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+ max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
+ min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+
+--instance Read PackedString: ToDo
+
+instance Show PackedString where
+ showsPrec p ps r = showsPrec p (unpackPS ps) r
+ showList = showList__ (showsPrec 0)
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString")
+
+-- -----------------------------------------------------------------------------
+-- PackedString instances
+
+-- We try hard to make this go fast:
+
+comparePS :: PackedString -> PackedString -> Ordering
+
+comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
+ | not has_null1 && not has_null2
+ = unsafePerformIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
+ ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2
+
+comparePS (PS bs1 len1 has_null1) (CPS bs2 _)
+ | not has_null1
+ = unsafePerformIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1
+ ba2 = Ptr bs2
+
+comparePS (CPS bs1 len1) (CPS bs2 _)
+ = unsafePerformIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = Ptr bs1
+ ba2 = Ptr bs2
+
+comparePS a@(CPS _ _) b@(PS _ _ has_null2)
+ | not has_null2
+ = -- try them the other way 'round
+ case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
+
+comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
+ = looking_at 0#
+ where
+ end1 = lengthPS# ps1 -# 1#
+ end2 = lengthPS# ps2 -# 1#
+
+ looking_at char#
+ = if char# ># end1 then
+ if char# ># end2 then -- both strings ran out at once
+ EQ
+ else -- ps1 ran out before ps2
+ LT
+ else if char# ># end2 then
+ GT -- ps2 ran out before ps1
+ else
+ let
+ ch1 = indexPS# ps1 char#
+ ch2 = indexPS# ps2 char#
+ in
+ if ch1 `eqChar#` ch2 then
+ looking_at (char# +# 1#)
+ else if ch1 `ltChar#` ch2 then LT
+ else GT
+
+
+-- -----------------------------------------------------------------------------
+-- Constructor functions
+
+-- Easy ones first. @packString@ requires getting some heap-bytes and
+-- scribbling stuff into them.
+
+nilPS :: PackedString
+nilPS = CPS ""# 0#
+
+consPS :: Char -> PackedString -> PackedString
+consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
+
+packString :: [Char] -> PackedString
+packString str = runST (packStringST str)
+
+packStringST :: [Char] -> ST s PackedString
+packStringST str =
+ let len = length str in
+ packNCharsST len str
+
+packNCharsST :: Int -> [Char] -> ST s PackedString
+packNCharsST (I# length#) str =
+ {-
+ allocate an array that will hold the string
+ (not forgetting the NUL byte at the end)
+ -}
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
+ -- fill in packed string from "str"
+ fill_in ch_array 0# str >>
+ -- freeze the puppy:
+ freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length# in
+ return (PS frozen# length# has_null)
+ where
+ fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
+ fill_in arr_in# idx [] =
+ write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+
+ fill_in arr_in# idx (C# c : cs) =
+ write_ps_array arr_in# idx c >>
+ fill_in arr_in# (idx +# 1#) cs
+
+byteArrayToPS :: ByteArray Int -> PackedString
+byteArrayToPS (ByteArray l u frozen#) =
+ let
+ ixs = (l,u)
+ n# =
+ case (
+ if null (range ixs)
+ then 0
+ else ((index ixs u) + 1)
+ ) of { I# x -> x }
+ in
+ PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+-- byteArray is zero-terminated, make everything upto it
+-- a packed string.
+cByteArrayToPS :: ByteArray Int -> PackedString
+cByteArrayToPS (ByteArray l u frozen#) =
+ let
+ ixs = (l,u)
+ n# =
+ case (
+ if null (range ixs)
+ then 0
+ else ((index ixs u) + 1)
+ ) of { I# x -> x }
+ len# = findNull 0#
+
+ findNull i#
+ | i# ==# n# = n#
+ | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel
+ | otherwise = findNull (i# +# 1#)
+ where
+ ch# = indexCharArray# frozen# i#
+ in
+ PS frozen# len# False
+
+unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
+unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#)
+ = PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+psToByteArray :: PackedString -> ByteArray Int
+psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes
+
+psToByteArray (CPS addr len#)
+ = let
+ len = I# len#
+ byte_array_form = packCBytes len (Ptr addr)
+ in
+ case byte_array_form of { PS bytes _ _ ->
+ ByteArray 0 (len - 1) bytes }
+
+-- isCString is useful when passing PackedStrings to the
+-- outside world, and need to figure out whether you can
+-- pass it as an Addr or ByteArray.
+--
+isCString :: PackedString -> Bool
+isCString (CPS _ _ ) = True
+isCString _ = False
+
+-- psToCString doesn't add a zero terminator!
+-- this doesn't appear to be very useful --SDM
+psToCString :: PackedString -> Ptr a
+psToCString (CPS addr _) = (Ptr addr)
+psToCString (PS bytes l# _) =
+ unsafePerformIO $ do
+ stuff <- mallocBytes (I# (l# +# 1#))
+ let
+ fill_in n# i#
+ | n# ==# 0# = return ()
+ | otherwise = do
+ let ch# = indexCharArray# bytes i#
+ pokeByteOff stuff (I# i#) (castCharToCChar (C# ch#))
+ fill_in (n# -# 1#) (i# +# 1#)
+ fill_in l# 0#
+ pokeByteOff stuff (I# l#) (C# '\0'#)
+ return stuff
+
+-- -----------------------------------------------------------------------------
+-- Destructor functions (taking PackedStrings apart)
+
+-- OK, but this code gets *hammered*:
+-- unpackPS ps
+-- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
+
+unpackPS :: PackedString -> [Char]
+unpackPS (PS bytes len _) = unpack 0#
+ where
+ unpack nh
+ | nh >=# len = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharArray# bytes nh
+
+unpackPS (CPS addr _) = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackNBytesPS :: PackedString -> Int -> [Char]
+unpackNBytesPS ps len@(I# l#)
+ | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len)
+ | len == 0 = []
+ | otherwise =
+ case ps of
+ PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null)
+ CPS a len# -> unpackPS (CPS a (min# len# l#))
+ where
+ min# x# y#
+ | x# <# y# = x#
+ | otherwise = y#
+
+unpackPSIO :: PackedString -> IO String
+unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps)
+unpackPSIO (CPS addr _) = unpack 0#
+ where
+ unpack nh = do
+ ch <- peekByteOff (Ptr addr) (I# nh)
+ let c = castCCharToChar ch
+ if c == '\0'
+ then return []
+ else do
+ ls <- unpack (nh +# 1#)
+ return (c : ls)
+
+-- Output a packed string via a handle:
+
+hPutPS :: Handle -> PackedString -> IO ()
+hPutPS handle (CPS a# len#) = hPutBuf handle (Ptr a#) (I# len#)
+hPutPS handle (PS ba# len# _) = do
+ let mba = MutableByteArray (bottom::Int) bottom (unsafeCoerce# ba#)
+ hPutBufBA handle mba (I# len#)
+ where
+ bottom = error "hPutPS"
+
+-- The dual to @_putPS@, note that the size of the chunk specified
+-- is the upper bound of the size of the chunk returned.
+
+hGetPS :: Handle -> Int -> IO PackedString
+hGetPS hdl len@(I# len#)
+ | len# <=# 0# = return nilPS -- I'm being kind here.
+ | otherwise =
+ -- Allocate an array for system call to store its bytes into.
+ stToIO (new_ps_array len# ) >>= \ ch_arr ->
+ stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ _ frozen#) ->
+ hGetBufBA hdl ch_arr len >>= \ (I# read#) ->
+ if read# ==# 0# then -- EOF or other error
+ ioError (userError "hGetPS: EOF reached or other error")
+ else
+ {-
+ The system call may not return the number of
+ bytes requested. Instead of failing with an error
+ if the number of bytes read is less than requested,
+ a packed string containing the bytes we did manage
+ to snarf is returned.
+ -}
+ let
+ has_null = byteArrayHasNUL# frozen# read#
+ in
+ return (PS frozen# read# has_null)
+
+-- -----------------------------------------------------------------------------
+-- List-mimicking functions for PackedStrings
+
+-- First, the basic functions that do look into the representation;
+-- @indexPS@ is the most important one.
+
+lengthPS :: PackedString -> Int
+lengthPS ps = I# (lengthPS# ps)
+
+{-# INLINE lengthPS# #-}
+
+lengthPS# :: PackedString -> Int#
+lengthPS# (PS _ i _) = i
+lengthPS# (CPS _ i) = i
+
+{-# INLINE strlen# #-}
+
+strlen# :: Addr# -> Int
+strlen# a
+ = unsafePerformIO (
+ _ccall_ strlen (Ptr a) >>= \ len@(I# _) ->
+ return len
+ )
+
+byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
+byteArrayHasNUL# bs len
+ = unsafePerformIO (
+ _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
+ return (
+ if res ==# 0# then False else True
+ ))
+ where
+ ba = ByteArray 0 (I# (len -# 1#)) bs
+
+-----------------------
+
+indexPS :: PackedString -> Int -> Char
+indexPS ps (I# n) = C# (indexPS# ps n)
+
+{-# INLINE indexPS# #-}
+
+indexPS# :: PackedString -> Int# -> Char#
+indexPS# (PS bs i _) n
+ = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
+ indexCharArray# bs n
+
+indexPS# (CPS a _) n
+ = indexCharOffAddr# a n
+
+-- Now, the rest of the functions can be defined without digging
+-- around in the representation.
+
+headPS :: PackedString -> Char
+headPS ps
+ | nullPS ps = error "headPS: head []"
+ | otherwise = C# (indexPS# ps 0#)
+
+tailPS :: PackedString -> PackedString
+tailPS ps
+ | len <=# 0# = error "tailPS: tail []"
+ | len ==# 1# = nilPS
+ | otherwise = substrPS# ps 1# (len -# 1#)
+ where
+ len = lengthPS# ps
+
+nullPS :: PackedString -> Bool
+nullPS (PS _ i _) = i ==# 0#
+nullPS (CPS _ i) = i ==# 0#
+
+appendPS :: PackedString -> PackedString -> PackedString
+appendPS xs ys
+ | nullPS xs = ys
+ | nullPS ys = xs
+ | otherwise = concatPS [xs,ys]
+
+mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
+mapPS f xs =
+ if nullPS xs then
+ xs
+ else
+ runST (
+ new_ps_array (length +# 1#) >>= \ ps_arr ->
+ whizz ps_arr length 0# >>
+ freeze_ps_array ps_arr length >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length in
+ return (PS frozen# length has_null))
+ where
+ length = lengthPS# xs
+
+ whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+ whizz arr# n i
+ | n ==# 0#
+ = write_ps_array arr# i (chr# 0#) >>
+ return ()
+ | otherwise
+ = let
+ ch = indexPS# xs i
+ in
+ write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
+ whizz arr# (n -# 1#) (i +# 1#)
+
+filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
+filterPS pred ps =
+ if nullPS ps then
+ ps
+ else
+ {-
+ Filtering proceeds as follows:
+
+ * traverse the list, applying the pred. to each element,
+ remembering the positions where it was satisfied.
+
+ Encode these positions using a run-length encoding of the gaps
+ between the matching positions.
+
+ * Allocate a MutableByteArray in the heap big enough to hold
+ all the matched entries, and copy the elements that matched over.
+
+ A better solution that merges the scan© passes into one,
+ would be to copy the filtered elements over into a growable
+ buffer. No such operation currently supported over
+ MutableByteArrays (could of course use malloc&realloc)
+ But, this solution may in the case of repeated realloc's
+ be worse than the current solution.
+ -}
+ runST (
+ let
+ (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# []
+ len_filtered# = case len_filtered of { I# x# -> x#}
+ in
+ if len# ==# len_filtered# then
+ {- not much filtering as everything passed through. -}
+ return ps
+ else if len_filtered# ==# 0# then
+ return nilPS
+ else
+ new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
+ copy_arr ps_arr rle 0# 0# >>
+ freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# len_filtered# in
+ return (PS frozen# len_filtered# has_null))
+ where
+ len# = lengthPS# ps
+
+ matchOffset :: Int# -> [Char] -> (Int,[Char])
+ matchOffset off [] = (I# off,[])
+ matchOffset off (C# c:cs) =
+ let
+ x = ord# c
+ off' = off +# x
+ in
+ if x==# 0# then -- escape code, add 255#
+ matchOffset off' cs
+ else
+ (I# off', cs)
+
+ copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
+ copy_arr _ [_] _ _ = return ()
+ copy_arr arr# ls n i =
+ let
+ (x,ls') = matchOffset 0# ls
+ n' = n +# (case x of { (I# x#) -> x#}) -# 1#
+ ch = indexPS# ps n'
+ in
+ write_ps_array arr# i ch >>
+ copy_arr arr# ls' (n' +# 1#) (i +# 1#)
+
+ esc :: Int# -> Int# -> [Char] -> [Char]
+ esc v 0# ls = (C# (chr# v)):ls
+ esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
+
+ filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
+ filter_ps n hits run acc
+ | n <# 0# =
+ let
+ escs = run `quotInt#` 255#
+ v = run `remInt#` 255#
+ in
+ (esc (v +# 1#) escs acc, I# hits)
+ | otherwise
+ = let
+ ch = indexPS# ps n
+ n' = n -# 1#
+ in
+ if pred (C# ch) then
+ let
+ escs = run `quotInt#` 255#
+ v = run `remInt#` 255#
+ acc' = esc (v +# 1#) escs acc
+ in
+ filter_ps n' (hits +# 1#) 0# acc'
+ else
+ filter_ps n' hits (run +# 1#) acc
+
+
+foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
+foldlPS f b ps
+ = if nullPS ps then
+ b
+ else
+ whizzLR b 0#
+ where
+ len = lengthPS# ps
+
+ --whizzLR :: a -> Int# -> a
+ whizzLR b idx
+ | idx ==# len = b
+ | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
+
+
+foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
+foldrPS f v ps
+ | nullPS ps = v
+ | otherwise = whizzRL v len
+ where
+ len = lengthPS# ps
+
+ --whizzRL :: a -> Int# -> a
+ whizzRL b idx
+ | idx <# 0# = b
+ | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
+
+takePS :: Int -> PackedString -> PackedString
+takePS (I# n) ps
+ | n ==# 0# = nilPS
+ | otherwise = substrPS# ps 0# (n -# 1#)
+
+dropPS :: Int -> PackedString -> PackedString
+dropPS (I# n) ps
+ | n ==# len = nilPS
+ | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
+ where
+ len = lengthPS# ps
+
+splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
+splitAtPS n ps = (takePS n ps, dropPS n ps)
+
+takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+takeWhilePS pred ps
+ = let
+ break_pt = char_pos_that_dissatisfies
+ (\ c -> pred (C# c))
+ ps
+ (lengthPS# ps)
+ 0#
+ in
+ if break_pt ==# 0# then
+ nilPS
+ else
+ substrPS# ps 0# (break_pt -# 1#)
+
+dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+dropWhilePS pred ps
+ = let
+ len = lengthPS# ps
+ break_pt = char_pos_that_dissatisfies
+ (\ c -> pred (C# c))
+ ps
+ len
+ 0#
+ in
+ if len ==# break_pt then
+ nilPS
+ else
+ substrPS# ps break_pt (len -# 1#)
+
+elemPS :: Char -> PackedString -> Bool
+elemPS (C# ch) ps
+ = let
+ len = lengthPS# ps
+ break_pt = first_char_pos_that_satisfies
+ (`eqChar#` ch)
+ ps
+ len
+ 0#
+ in
+ break_pt <# len
+
+char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+
+char_pos_that_dissatisfies p ps len pos
+ | pos >=# len = pos -- end
+ | p (indexPS# ps pos) = -- predicate satisfied; keep going
+ char_pos_that_dissatisfies p ps len (pos +# 1#)
+ | otherwise = pos -- predicate not satisfied
+
+first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+first_char_pos_that_satisfies p ps len pos
+ | pos >=# len = pos -- end
+ | p (indexPS# ps pos) = pos -- got it!
+ | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
+
+-- ToDo: could certainly go quicker
+spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
+
+breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+breakPS p ps = spanPS (not . p) ps
+
+linesPS :: PackedString -> [PackedString]
+linesPS ps = splitPS '\n' ps
+
+wordsPS :: PackedString -> [PackedString]
+wordsPS ps = splitWithPS isSpace ps
+
+reversePS :: PackedString -> PackedString
+reversePS ps =
+ if nullPS ps then -- don't create stuff unnecessarily.
+ ps
+ else
+ runST (
+ new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
+ fill_in arr# (length -# 1#) 0# >>
+ freeze_ps_array arr# length >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length in
+ return (PS frozen# length has_null))
+ where
+ length = lengthPS# ps
+
+ fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+ fill_in arr_in# n i =
+ let
+ ch = indexPS# ps n
+ in
+ write_ps_array arr_in# i ch >>
+ if n ==# 0# then
+ write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
+ return ()
+ else
+ fill_in arr_in# (n -# 1#) (i +# 1#)
+
+concatPS :: [PackedString] -> PackedString
+concatPS [] = nilPS
+concatPS pss
+ = let
+ tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
+ in
+ runST (
+ new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
+ packum arr# pss 0# >>
+ freeze_ps_array arr# tot_len# >>= \ (ByteArray _ _ frozen#) ->
+
+ let has_null = byteArrayHasNUL# frozen# tot_len# in
+
+ return (PS frozen# tot_len# has_null)
+ )
+ where
+ packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
+
+ packum arr [] pos
+ = write_ps_array arr pos (chr# 0#) >>
+ return ()
+ packum arr (ps : pss) pos
+ = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
+ packum arr pss next_pos
+
+ fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
+
+ fill arr arr_i ps ps_i ps_len
+ | ps_i ==# ps_len
+ = return (I# (arr_i +# ps_len))
+ | otherwise
+ = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
+ fill arr arr_i ps (ps_i +# 1#) ps_len
+
+------------------------------------------------------------
+joinPS :: PackedString -> [PackedString] -> PackedString
+joinPS filler pss = concatPS (splice pss)
+ where
+ splice [] = []
+ splice [x] = [x]
+ splice (x:y:xs) = x:filler:splice (y:xs)
+
+-- ToDo: the obvious generalisation
+{-
+ Some properties that hold:
+
+ * splitPS x ls = ls'
+ where False = any (map (x `elemPS`) ls')
+ False = any (map (nullPS) ls')
+
+ * all x's have been chopped out.
+ * no empty PackedStrings in returned list. A conseq.
+ of this is:
+ splitPS x nilPS = []
+
+
+ * joinPS (packString [x]) (_splitPS x ls) = ls
+
+-}
+
+splitPS :: Char -> PackedString -> [PackedString]
+splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
+
+splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
+splitWithPS pred ps =
+ splitify 0#
+ where
+ len = lengthPS# ps
+
+ splitify n
+ | n >=# len = []
+ | otherwise =
+ let
+ break_pt =
+ first_char_pos_that_satisfies
+ (\ c -> pred (C# c))
+ ps
+ len
+ n
+ in
+ if break_pt ==# n then -- immediate match, no substring to cut out.
+ splitify (break_pt +# 1#)
+ else
+ substrPS# ps n (break_pt -# 1#): -- leave out the matching character
+ splitify (break_pt +# 1#)
+
+-- -----------------------------------------------------------------------------
+-- Local utility functions
+
+-- The definition of @_substrPS@ is essentially:
+-- @take (end - begin + 1) (drop begin str)@.
+
+substrPS :: PackedString -> Int -> Int -> PackedString
+substrPS ps (I# begin) (I# end) = substrPS# ps begin end
+
+substrPS# :: PackedString -> Int# -> Int# -> PackedString
+substrPS# ps s e
+ | s <# 0# || s >=# len || result_len# <=# 0#
+ = nilPS
+
+ | otherwise
+ = runST (
+ new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
+ fill_in ch_arr 0# >>
+ freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ _ frozen#) ->
+
+ let has_null = byteArrayHasNUL# frozen# result_len# in
+
+ return (PS frozen# result_len# has_null)
+ )
+ where
+ len = lengthPS# ps
+
+ result_len# = (if e <# len then (e +# 1#) else len) -# s
+
+ -----------------------
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+ fill_in arr_in# idx
+ | idx ==# result_len#
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+ | otherwise
+ = let
+ ch = indexPS# ps (s +# idx)
+ in
+ write_ps_array arr_in# idx ch >>
+ fill_in arr_in# (idx +# 1#)
+
+-- -----------------------------------------------------------------------------
+-- Packing and unpacking C strings
+
+cStringToPS :: Ptr a -> PackedString
+cStringToPS (Ptr a#) = -- the easy one; we just believe the caller
+ CPS a# len
+ where
+ len = case (strlen# a#) of { I# x -> x }
+
+packCBytes :: Int -> Ptr a -> PackedString
+packCBytes len addr = runST (packCBytesST len addr)
+
+packCBytesST :: Int -> Ptr a -> ST s PackedString
+packCBytesST (I# length#) (Ptr addr) =
+ {-
+ allocate an array that will hold the string
+ (not forgetting the NUL byte at the end)
+ -}
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
+ -- fill in packed string from "addr"
+ fill_in ch_array 0# >>
+ -- freeze the puppy:
+ freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length# in
+ return (PS frozen# length# has_null)
+ where
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+ fill_in arr_in# idx
+ | idx ==# length#
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+ | otherwise
+ = case (indexCharOffAddr# addr idx) of { ch ->
+ write_ps_array arr_in# idx ch >>
+ fill_in arr_in# (idx +# 1#) }
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.Ratio
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Ratio.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Standard functions on rational numbers
+--
+-----------------------------------------------------------------------------
+
+module Data.Ratio
+ ( Ratio
+ , Rational
+ , (%) -- :: (Integral a) => a -> a -> Ratio a
+ , numerator -- :: (Integral a) => Ratio a -> a
+ , denominator -- :: (Integral a) => Ratio a -> a
+ , approxRational -- :: (RealFrac a) => a -> a -> Rational
+
+ -- Ratio instances:
+ -- (Integral a) => Eq (Ratio a)
+ -- (Integral a) => Ord (Ratio a)
+ -- (Integral a) => Num (Ratio a)
+ -- (Integral a) => Real (Ratio a)
+ -- (Integral a) => Fractional (Ratio a)
+ -- (Integral a) => RealFrac (Ratio a)
+ -- (Integral a) => Enum (Ratio a)
+ -- (Read a, Integral a) => Read (Ratio a)
+ -- (Integral a) => Show (Ratio a)
+
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Real -- The basic defns for Ratio
+#endif
+
+-- -----------------------------------------------------------------------------
+-- approxRational
+
+-- @approxRational@, applied to two real fractional numbers x and epsilon,
+-- returns the simplest rational number within epsilon of x. A rational
+-- number n%d in reduced form is said to be simpler than another n'%d' if
+-- abs n <= abs n' && d <= d'. Any real interval contains a unique
+-- simplest rational; here, for simplicity, we assume a closed rational
+-- interval. If such an interval includes at least one whole number, then
+-- the simplest rational is the absolutely least whole number. Otherwise,
+-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+-- the simplest rational between d'%r' and d%r.
+
+approxRational :: (RealFrac a) => a -> a -> Rational
+approxRational rat eps = simplest (rat-eps) (rat+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr = toRational x
+ n = numerator xr
+ d = denominator xr
+ nd' = toRational y
+ n' = numerator nd'
+ d' = denominator nd'
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ nd'' = simplest' d' r' d r
+ n'' = numerator nd''
+ d'' = denominator nd''
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Data.STRef
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: STRef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Mutable references in the ST monad.
+--
+-----------------------------------------------------------------------------
+
+module Data.STRef (
+ STRef, -- abstract, instance Eq
+ newSTRef, -- :: a -> ST s (STRef s a)
+ readSTRef, -- :: STRef s a -> ST s a
+ writeSTRef -- :: STRef s a -> a -> ST s ()
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.STRef
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module :
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Word.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- Sized unsigned integer types.
+--
+-----------------------------------------------------------------------------
+
+module Data.Word
+ ( Word
+ , Word8
+ , Word16
+ , Word32
+ , Word64
+ -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
+ -- Show, Bits, CCallable, CReturnable (last two are GHC specific.)
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Word
+#endif
+
+import Data.Dynamic
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Word8,word8Tc, "Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Debug.Trace
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Trace.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $
+--
+-- The trace function.
+--
+-----------------------------------------------------------------------------
+
+module Debug.Trace (
+ trace -- :: String -> a -> a
+ ) where
+
+import Prelude
+import System.IO.Unsafe
+import System.IO
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+import GHC.Handle
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+{-# NOINLINE trace #-}
+trace :: String -> a -> a
+trace string expr = unsafePerformIO $ do
+ hPutStr stderr string
+ hPutChar stderr '\n'
+ fd <- withHandle_ "trace" stderr $ (return.haFD)
+ postTraceHook fd
+ return expr
+
+foreign import "PostTraceHook" postTraceHook :: Int -> IO ()
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Foreign.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- A collection of data types, classes, and functions for interfacing
+-- with another programming language. This is only a convenience module
+-- in the future, but currently it has the additional task of hiding
+-- those entities exported from other modules, which are not part of the
+-- FFI proposal.
+--
+-----------------------------------------------------------------------------
+
+module Foreign
+ ( module Data.Int
+ , module Data.Word
+ , module Foreign.Ptr
+ , module Foreign.ForeignPtr
+ , module Foreign.StablePtr
+ , module Foreign.Storable
+ , module Foreign.Marshal.Alloc
+ , module Foreign.Marshal.Array
+ , module Foreign.Marshal.Error
+ , module Foreign.Marshal.Utils
+ ) where
+
+import Data.Int
+import Data.Word
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.StablePtr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
+import Foreign.Marshal.Error
+import Foreign.Marshal.Utils
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.C
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: C.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Bundles the C specific FFI library functionality
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C
+ ( module Foreign.C.Types
+ , module Foreign.C.TypesISO
+ , module Foreign.C.String
+ , module Foreign.C.Error
+ ) where
+
+import Foreign.C.Types
+import Foreign.C.TypesISO
+import Foreign.C.String
+import Foreign.C.Error
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.C.Error
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Error.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- C-specific Marshalling support: Handling of C "errno" error codes
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.Error (
+
+ -- Haskell representation for "errno" values
+ --
+ Errno(..), -- instance: Eq
+ eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
+ eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
+ eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
+ eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
+ eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
+ eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
+ eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
+ eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
+ eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
+ eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
+ ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
+ eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
+ eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
+ eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV,
+ -- :: Errno
+ isValidErrno, -- :: Errno -> Bool
+
+ -- access to the current thread's "errno" value
+ --
+ getErrno, -- :: IO Errno
+ resetErrno, -- :: IO ()
+
+ -- conversion of an "errno" value into IO error
+ --
+ errnoToIOError, -- :: String -- location
+ -- -> Errno -- errno
+ -- -> Maybe Handle -- handle
+ -- -> Maybe String -- filename
+ -- -> IOError
+
+ -- throw current "errno" value
+ --
+ throwErrno, -- :: String -> IO a
+
+ -- guards for IO operations that may fail
+ --
+ throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a
+ throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO ()
+ throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a
+ throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO ()
+ throwErrnoIfMinus1, -- :: Num a
+ -- => String -> IO a -> IO a
+ throwErrnoIfMinus1_, -- :: Num a
+ -- => String -> IO a -> IO ()
+ throwErrnoIfMinus1Retry,
+ -- :: Num a
+ -- => String -> IO a -> IO a
+ throwErrnoIfMinus1Retry_,
+ -- :: Num a
+ -- => String -> IO a -> IO ()
+ throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a)
+ throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a)
+
+ throwErrnoIfRetryMayBlock,
+ throwErrnoIfRetryMayBlock_,
+ throwErrnoIfMinus1RetryMayBlock,
+ throwErrnoIfMinus1RetryMayBlock_,
+ throwErrnoIfNullRetryMayBlock
+) where
+
+
+-- this is were we get the CCONST_XXX definitions from that configure
+-- calculated for us
+--
+#include "config.h"
+
+-- system dependent imports
+-- ------------------------
+
+-- GHC allows us to get at the guts inside IO errors/exceptions
+--
+#if __GLASGOW_HASKELL__
+import GHC.IOBase (Exception(..), IOException(..), IOErrorType(..))
+#endif /* __GLASGOW_HASKELL__ */
+
+
+-- regular imports
+-- ---------------
+
+import Foreign.Ptr
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Marshal.Error ( void )
+import Data.Maybe
+
+#if __GLASGOW_HASKELL__
+import GHC.Storable
+import GHC.IOBase
+import GHC.Num
+import GHC.Base
+#else
+import System.IO ( IOError, Handle, ioError )
+#endif
+
+-- "errno" type
+-- ------------
+
+-- import of C function that gives address of errno
+--
+foreign import "ghcErrno" unsafe _errno :: Ptr CInt
+
+-- Haskell representation for "errno" values
+--
+newtype Errno = Errno CInt
+
+instance Eq Errno where
+ errno1@(Errno no1) == errno2@(Errno no2)
+ | isValidErrno errno1 && isValidErrno errno2 = no1 == no2
+ | otherwise = False
+
+-- common "errno" symbols
+--
+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN,
+ eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED,
+ eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT,
+ eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ,
+ eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK,
+ eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH,
+ eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK,
+ eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS,
+ eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO,
+ eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL,
+ ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE,
+ eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN,
+ eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT,
+ eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno
+--
+-- the CCONST_XXX identifiers are cpp symbols whose value is computed by
+-- configure
+--
+eOK = Errno 0
+e2BIG = Errno (CCONST_E2BIG)
+eACCES = Errno (CCONST_EACCES)
+eADDRINUSE = Errno (CCONST_EADDRINUSE)
+eADDRNOTAVAIL = Errno (CCONST_EADDRNOTAVAIL)
+eADV = Errno (CCONST_EADV)
+eAFNOSUPPORT = Errno (CCONST_EAFNOSUPPORT)
+eAGAIN = Errno (CCONST_EAGAIN)
+eALREADY = Errno (CCONST_EALREADY)
+eBADF = Errno (CCONST_EBADF)
+eBADMSG = Errno (CCONST_EBADMSG)
+eBADRPC = Errno (CCONST_EBADRPC)
+eBUSY = Errno (CCONST_EBUSY)
+eCHILD = Errno (CCONST_ECHILD)
+eCOMM = Errno (CCONST_ECOMM)
+eCONNABORTED = Errno (CCONST_ECONNABORTED)
+eCONNREFUSED = Errno (CCONST_ECONNREFUSED)
+eCONNRESET = Errno (CCONST_ECONNRESET)
+eDEADLK = Errno (CCONST_EDEADLK)
+eDESTADDRREQ = Errno (CCONST_EDESTADDRREQ)
+eDIRTY = Errno (CCONST_EDIRTY)
+eDOM = Errno (CCONST_EDOM)
+eDQUOT = Errno (CCONST_EDQUOT)
+eEXIST = Errno (CCONST_EEXIST)
+eFAULT = Errno (CCONST_EFAULT)
+eFBIG = Errno (CCONST_EFBIG)
+eFTYPE = Errno (CCONST_EFTYPE)
+eHOSTDOWN = Errno (CCONST_EHOSTDOWN)
+eHOSTUNREACH = Errno (CCONST_EHOSTUNREACH)
+eIDRM = Errno (CCONST_EIDRM)
+eILSEQ = Errno (CCONST_EILSEQ)
+eINPROGRESS = Errno (CCONST_EINPROGRESS)
+eINTR = Errno (CCONST_EINTR)
+eINVAL = Errno (CCONST_EINVAL)
+eIO = Errno (CCONST_EIO)
+eISCONN = Errno (CCONST_EISCONN)
+eISDIR = Errno (CCONST_EISDIR)
+eLOOP = Errno (CCONST_ELOOP)
+eMFILE = Errno (CCONST_EMFILE)
+eMLINK = Errno (CCONST_EMLINK)
+eMSGSIZE = Errno (CCONST_EMSGSIZE)
+eMULTIHOP = Errno (CCONST_EMULTIHOP)
+eNAMETOOLONG = Errno (CCONST_ENAMETOOLONG)
+eNETDOWN = Errno (CCONST_ENETDOWN)
+eNETRESET = Errno (CCONST_ENETRESET)
+eNETUNREACH = Errno (CCONST_ENETUNREACH)
+eNFILE = Errno (CCONST_ENFILE)
+eNOBUFS = Errno (CCONST_ENOBUFS)
+eNODATA = Errno (CCONST_ENODATA)
+eNODEV = Errno (CCONST_ENODEV)
+eNOENT = Errno (CCONST_ENOENT)
+eNOEXEC = Errno (CCONST_ENOEXEC)
+eNOLCK = Errno (CCONST_ENOLCK)
+eNOLINK = Errno (CCONST_ENOLINK)
+eNOMEM = Errno (CCONST_ENOMEM)
+eNOMSG = Errno (CCONST_ENOMSG)
+eNONET = Errno (CCONST_ENONET)
+eNOPROTOOPT = Errno (CCONST_ENOPROTOOPT)
+eNOSPC = Errno (CCONST_ENOSPC)
+eNOSR = Errno (CCONST_ENOSR)
+eNOSTR = Errno (CCONST_ENOSTR)
+eNOSYS = Errno (CCONST_ENOSYS)
+eNOTBLK = Errno (CCONST_ENOTBLK)
+eNOTCONN = Errno (CCONST_ENOTCONN)
+eNOTDIR = Errno (CCONST_ENOTDIR)
+eNOTEMPTY = Errno (CCONST_ENOTEMPTY)
+eNOTSOCK = Errno (CCONST_ENOTSOCK)
+eNOTTY = Errno (CCONST_ENOTTY)
+eNXIO = Errno (CCONST_ENXIO)
+eOPNOTSUPP = Errno (CCONST_EOPNOTSUPP)
+ePERM = Errno (CCONST_EPERM)
+ePFNOSUPPORT = Errno (CCONST_EPFNOSUPPORT)
+ePIPE = Errno (CCONST_EPIPE)
+ePROCLIM = Errno (CCONST_EPROCLIM)
+ePROCUNAVAIL = Errno (CCONST_EPROCUNAVAIL)
+ePROGMISMATCH = Errno (CCONST_EPROGMISMATCH)
+ePROGUNAVAIL = Errno (CCONST_EPROGUNAVAIL)
+ePROTO = Errno (CCONST_EPROTO)
+ePROTONOSUPPORT = Errno (CCONST_EPROTONOSUPPORT)
+ePROTOTYPE = Errno (CCONST_EPROTOTYPE)
+eRANGE = Errno (CCONST_ERANGE)
+eREMCHG = Errno (CCONST_EREMCHG)
+eREMOTE = Errno (CCONST_EREMOTE)
+eROFS = Errno (CCONST_EROFS)
+eRPCMISMATCH = Errno (CCONST_ERPCMISMATCH)
+eRREMOTE = Errno (CCONST_ERREMOTE)
+eSHUTDOWN = Errno (CCONST_ESHUTDOWN)
+eSOCKTNOSUPPORT = Errno (CCONST_ESOCKTNOSUPPORT)
+eSPIPE = Errno (CCONST_ESPIPE)
+eSRCH = Errno (CCONST_ESRCH)
+eSRMNT = Errno (CCONST_ESRMNT)
+eSTALE = Errno (CCONST_ESTALE)
+eTIME = Errno (CCONST_ETIME)
+eTIMEDOUT = Errno (CCONST_ETIMEDOUT)
+eTOOMANYREFS = Errno (CCONST_ETOOMANYREFS)
+eTXTBSY = Errno (CCONST_ETXTBSY)
+eUSERS = Errno (CCONST_EUSERS)
+eWOULDBLOCK = Errno (CCONST_EWOULDBLOCK)
+eXDEV = Errno (CCONST_EXDEV)
+
+-- checks whether the given errno value is supported on the current
+-- architecture
+--
+isValidErrno :: Errno -> Bool
+--
+-- the configure script sets all invalid "errno"s to -1
+--
+isValidErrno (Errno errno) = errno /= -1
+
+
+-- access to the current thread's "errno" value
+-- --------------------------------------------
+
+-- yield the current thread's "errno" value
+--
+getErrno :: IO Errno
+getErrno = do e <- peek _errno; return (Errno e)
+
+-- set the current thread's "errno" value to 0
+--
+resetErrno :: IO ()
+resetErrno = poke _errno 0
+
+
+-- throw current "errno" value
+-- ---------------------------
+
+-- the common case: throw an IO error based on a textual description
+-- of the error location and the current thread's "errno" value
+--
+throwErrno :: String -> IO a
+throwErrno loc =
+ do
+ errno <- getErrno
+ ioError (errnoToIOError loc errno Nothing Nothing)
+
+
+-- guards for IO operations that may fail
+-- --------------------------------------
+
+-- guard an IO operation and throw an "errno" based exception of the result
+-- value of the IO operation meets the given predicate
+--
+throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a
+throwErrnoIf pred loc f =
+ do
+ res <- f
+ if pred res then throwErrno loc else return res
+
+-- as `throwErrnoIf', but discards the result
+--
+throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f
+
+-- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose
+-- flag `EINTR')
+--
+throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a
+throwErrnoIfRetry pred loc f =
+ do
+ res <- f
+ if pred res
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfRetry pred loc f
+ else throwErrno loc
+ else return res
+
+-- as `throwErrnoIfRetry', but checks for operations that would block and
+-- executes an alternative action in that case.
+
+throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a
+throwErrnoIfRetryMayBlock pred loc f on_block =
+ do
+ res <- f
+ if pred res
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfRetryMayBlock pred loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
+ else throwErrno loc
+ else return res
+
+-- as `throwErrnoIfRetry', but discards the result
+--
+throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
+
+-- as `throwErrnoIfRetryMayBlock', but discards the result
+--
+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
+throwErrnoIfRetryMayBlock_ pred loc f on_block
+ = void $ throwErrnoIfRetryMayBlock pred loc f on_block
+
+-- throws "errno" if a result of "-1" is returned
+--
+throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1 = throwErrnoIf (== -1)
+
+-- as `throwErrnoIfMinus1', but discards the result
+--
+throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1_ = throwErrnoIf_ (== -1)
+
+-- throws "errno" if a result of "-1" is returned, but retries in case of an
+-- interrupted operation
+--
+throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1)
+
+-- as `throwErrnoIfMinus1', but discards the result
+--
+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1)
+
+-- as throwErrnoIfMinus1Retry, but checks for operations that would block
+--
+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1)
+
+-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result
+--
+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1)
+
+-- throws "errno" if a result of a NULL pointer is returned
+--
+throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNull = throwErrnoIf (== nullPtr)
+
+-- throws "errno" if a result of a NULL pointer is returned, but retries in
+-- case of an interrupted operation
+--
+throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr)
+
+-- as throwErrnoIfNullRetry, but checks for operations that would block
+--
+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
+throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr)
+
+-- conversion of an "errno" value into IO error
+-- --------------------------------------------
+
+-- convert a location string, an "errno" value, an optional handle,
+-- and an optional filename into a matching IO error
+--
+errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError
+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
+ str <- strerror errno >>= peekCString
+#if __GLASGOW_HASKELL__
+ return (IOException (IOError maybeHdl errType loc str maybeName))
+ where
+ errType
+ | errno == eOK = OtherError
+ | errno == e2BIG = ResourceExhausted
+ | errno == eACCES = PermissionDenied
+ | errno == eADDRINUSE = ResourceBusy
+ | errno == eADDRNOTAVAIL = UnsupportedOperation
+ | errno == eADV = OtherError
+ | errno == eAFNOSUPPORT = UnsupportedOperation
+ | errno == eAGAIN = ResourceExhausted
+ | errno == eALREADY = AlreadyExists
+ | errno == eBADF = OtherError
+ | errno == eBADMSG = InappropriateType
+ | errno == eBADRPC = OtherError
+ | errno == eBUSY = ResourceBusy
+ | errno == eCHILD = NoSuchThing
+ | errno == eCOMM = ResourceVanished
+ | errno == eCONNABORTED = OtherError
+ | errno == eCONNREFUSED = NoSuchThing
+ | errno == eCONNRESET = ResourceVanished
+ | errno == eDEADLK = ResourceBusy
+ | errno == eDESTADDRREQ = InvalidArgument
+ | errno == eDIRTY = UnsatisfiedConstraints
+ | errno == eDOM = InvalidArgument
+ | errno == eDQUOT = PermissionDenied
+ | errno == eEXIST = AlreadyExists
+ | errno == eFAULT = OtherError
+ | 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 = NoSuchThing
+ | 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 unsafe strerror :: Errno -> IO (Ptr CChar)
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.C.String
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: String.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Utilities for primitive marshaling
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.String ( -- representation of strings in C
+
+ CString, -- = Ptr CChar
+ CStringLen, -- = (CString, Int)
+
+ -- 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
+
+ -- conversion between Haskell and C characters *ignoring* the encoding
+ --
+ castCharToCChar, -- :: Char -> CChar
+ castCCharToChar, -- :: CChar -> Char
+
+ -- UnsafeCString: these might be more efficient than CStrings when
+ -- passing the string to an "unsafe" foreign import. NOTE: this
+ -- feature might be removed in favour of a more general approach in
+ -- the future.
+ --
+ UnsafeCString, -- abstract
+ withUnsafeCString, -- :: String -> (UnsafeCString -> IO a) -> IO a
+
+ ) where
+
+import Foreign.Marshal.Array
+import Foreign.C.Types
+import Foreign.Ptr
+
+import Data.Word
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.ByteArr
+import GHC.Pack
+import GHC.List
+import GHC.Real
+import GHC.Num
+import GHC.IOBase
+import GHC.Base
+#endif
+
+-----------------------------------------------------------------------------
+-- Strings
+
+-- representation of strings in C
+-- ------------------------------
+
+type CString = Ptr CChar -- conventional NUL terminates strings
+type CStringLen = (CString, Int) -- strings with explicit length
+
+
+-- exported functions
+-- ------------------
+--
+-- * the following routines apply the default conversion when converting the
+-- C-land character encoding into the Haskell-land character encoding
+--
+-- ** NOTE: The current implementation doesn't handle conversions yet! **
+--
+-- * the routines using an explicit length tolerate NUL characters in the
+-- middle of a string
+--
+
+-- marshal a NUL terminated C string into a Haskell string
+--
+peekCString :: CString -> IO String
+peekCString cp = do cs <- peekArray0 nUL cp; return (cCharsToChars cs)
+
+-- marshal a C string with explicit length into a Haskell string
+--
+peekCStringLen :: CStringLen -> IO String
+peekCStringLen (cp, len) = do cs <- peekArray len cp; return (cCharsToChars cs)
+
+-- marshal a Haskell string into a NUL terminated C strings
+--
+-- * the Haskell string may *not* contain any NUL characters
+--
+-- * new storage is allocated for the C string and must be explicitly freed
+--
+newCString :: String -> IO CString
+newCString = newArray0 nUL . charsToCChars
+
+-- 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
+--
+newCStringLen :: String -> IO CStringLen
+newCStringLen str = do a <- newArray (charsToCChars str)
+ return (pairLength str a)
+
+-- marshal a Haskell string into a NUL terminated C strings using temporary
+-- storage
+--
+-- * the Haskell string may *not* contain any NUL characters
+--
+-- * see the lifetime constraints of `MarshalAlloc.alloca'
+--
+withCString :: String -> (CString -> IO a) -> IO a
+withCString = withArray0 nUL . charsToCChars
+
+-- marshal a Haskell string into a NUL terminated C strings using temporary
+-- storage
+--
+-- * the Haskell string may *not* contain any NUL characters
+--
+-- * see the lifetime constraints of `MarshalAlloc.alloca'
+--
+withCStringLen :: String -> (CStringLen -> IO a) -> IO a
+withCStringLen str act = withArray (charsToCChars str) $ act . pairLength str
+
+-- auxilliary 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 -> CString -> CStringLen
+pairLength = flip (,) . length
+
+-- cast [CChar] to [Char]
+--
+cCharsToChars :: [CChar] -> [Char]
+cCharsToChars = map castCCharToChar
+
+-- cast [Char] to [CChar]
+--
+charsToCChars :: [Char] -> [CChar]
+charsToCChars = map castCharToCChar
+
+castCCharToChar :: CChar -> Char
+castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8))
+
+castCharToCChar :: Char -> CChar
+castCharToCChar ch = fromIntegral (ord ch)
+
+
+-- unsafe CStrings
+-- ---------------
+
+withUnsafeCString :: String -> (UnsafeCString -> IO a) -> IO a
+#if __GLASGOW_HASKELL__
+newtype UnsafeCString = UnsafeCString (ByteArray Int)
+withUnsafeCString s f = f (UnsafeCString (packString s))
+#else
+newtype UnsafeCString = UnsafeCString (Ptr CChar)
+withUnsafeCString s f = withCString s (\p -> f (UnsafeCString p))
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.C.Types
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Types.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Mapping of C types to corresponding Haskell types. A cool hack...
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.Types
+ ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum,
+ -- Typeable, Storable, Bounded, Real, Integral, Bits
+ CChar(..), CSChar(..), CUChar(..)
+ , CShort(..), CUShort(..), CInt(..), CUInt(..)
+ , CLong(..), CULong(..), CLLong(..), CULLong(..)
+
+ -- Floating types, instances of: Eq, Ord, Num, Read, Show, Enum,
+ -- Typeable, Storable, Real, Fractional, Floating, RealFrac, RealFloat
+ , CFloat(..), CDouble(..), CLDouble(..)
+ ) where
+
+import Data.Bits ( Bits(..) )
+import Data.Int ( Int8, Int16, Int32, Int64 )
+import Data.Word ( Word8, Word16, Word32, Word64 )
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Float
+import GHC.Enum
+import GHC.Real
+import GHC.Show
+import GHC.Read
+import GHC.Num
+#endif
+
+#include "CTypes.h"
+
+INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR)
+INTEGRAL_TYPE(CSChar,tyConCSChar,"CSChar",HTYPE_SIGNED_CHAR)
+INTEGRAL_TYPE(CUChar,tyConCUChar,"CUChar",HTYPE_UNSIGNED_CHAR)
+
+INTEGRAL_TYPE(CShort,tyConCShort,"CShort",HTYPE_SHORT)
+INTEGRAL_TYPE(CUShort,tyConCUShort,"CUShort",HTYPE_UNSIGNED_SHORT)
+
+INTEGRAL_TYPE(CInt,tyConCInt,"CInt",HTYPE_INT)
+INTEGRAL_TYPE(CUInt,tyConCUInt,"CUInt",HTYPE_UNSIGNED_INT)
+
+INTEGRAL_TYPE(CLong,tyConCLong,"CLong",HTYPE_LONG)
+INTEGRAL_TYPE(CULong,tyConCULong,"CULong",HTYPE_UNSIGNED_LONG)
+
+INTEGRAL_TYPE(CLLong,tyConCLLong,"CLLong",HTYPE_LONG_LONG)
+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
+ #-}
+
+FLOATING_TYPE(CFloat,tyConCFloat,"CFloat",HTYPE_FLOAT)
+FLOATING_TYPE(CDouble,tyConCDouble,"CDouble",HTYPE_DOUBLE)
+-- HACK: Currently no long double in the FFI, so we simply re-use double
+FLOATING_TYPE(CLDouble,tyConCLDouble,"CLDouble",HTYPE_DOUBLE)
+
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(CChar,cCharTc,"CChar")
+INSTANCE_TYPEABLE0(CSChar,cSCharTc,"CSChar")
+INSTANCE_TYPEABLE0(CUChar,cUCharTc,"CUChar")
+
+INSTANCE_TYPEABLE0(CShort,cShortTc,"CShort")
+INSTANCE_TYPEABLE0(CUShort,cUShortTc,"CUShort")
+
+INSTANCE_TYPEABLE0(CInt,cIntTc,"CInt")
+INSTANCE_TYPEABLE0(CUInt,cUIntTc,"CUInt")
+
+INSTANCE_TYPEABLE0(CLong,cLongTc,"CLong")
+INSTANCE_TYPEABLE0(CULong,cULongTc,"CULong")
+
+INSTANCE_TYPEABLE0(CLLong,cLLongTc,"CLLong")
+INSTANCE_TYPEABLE0(CULLong,cULLongTc,"CULLong")
+
+INSTANCE_TYPEABLE0(CFloat,cFloatTc,"CFloat")
+INSTANCE_TYPEABLE0(CDouble,cDoubleTc,"CDouble")
+INSTANCE_TYPEABLE0(CLDouble,cLDoubleTc,"CLDouble")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.C.TypesISO
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: TypesISO.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- A mapping of C types defined by the ISO C standard to corresponding Haskell
+-- types. Like CTypes, this is a cool hack...
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.TypesISO
+ ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum,
+ -- Typeable, Storable, Bounded, Real, Integral, Bits
+ CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..)
+
+ -- Numeric types, instances of: Eq, Ord, Num, Read, Show, Enum,
+ -- Typeable, Storable
+ , CClock(..), CTime(..),
+
+ , CFile, CFpos, CJmpBuf
+ ) where
+
+import Data.Bits ( Bits(..) )
+import Data.Int
+import Data.Word
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.Enum
+import GHC.Real
+import GHC.Show
+import GHC.Read
+import GHC.Num
+#endif
+
+#include "CTypes.h"
+
+INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T)
+INTEGRAL_TYPE(CSize,tyConCSize,"CSize",HTYPE_SIZE_T)
+INTEGRAL_TYPE(CWchar,tyConCWchar,"CWchar",HTYPE_WCHAR_T)
+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
+ #-}
+
+INTEGRAL_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T)
+INTEGRAL_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T)
+
+-- TODO: Instances. But which...? :-}
+
+data CFile = CFile
+
+data CFpos = CFpos
+
+data CJmpBuf = CJmpBuf
+
+-- C99 types which are still missing include:
+-- intptr_t, uintptr_t, intmax_t, uintmax_t, wint_t, wctrans_t, wctype_t
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(CPtrdiff,cPtrdiffTc,"CPtrdiff")
+INSTANCE_TYPEABLE0(CSize,cSizeTc,"CSize")
+INSTANCE_TYPEABLE0(CWchar,cWcharTc,"CWchar")
+INSTANCE_TYPEABLE0(CSigAtomic,cSigAtomicTc,"CSigAtomic")
+INSTANCE_TYPEABLE0(CClock,cClockTc,"CClock")
+INSTANCE_TYPEABLE0(CTime,cTimeTc,"CTime")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.ForeignPtr
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: ForeignPtr.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- This module defines foreign pointers, i.e. addresses with associated
+-- finalizers.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.ForeignPtr
+ ( ForeignPtr, -- abstract, instance of: Eq
+ , newForeignPtr -- :: Ptr a -> IO () -> IO (ForeignPtr a)
+ , addForeignPtrFinalizer -- :: ForeignPtr a -> IO () -> IO ()
+ , withForeignPtr -- :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+ , foreignPtrToPtr -- :: ForeignPtr a -> Ptr a
+ , touchForeignPtr -- :: ForeignPtr a -> IO ()
+ , castForeignPtr -- :: ForeignPtr a -> ForeignPtr b
+ )
+ where
+
+import Foreign.Ptr
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.IOBase
+import GHC.Num
+import GHC.Err
+#endif
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+
+#ifdef __GLASGOW_HASKELL__
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
+
+eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
+eqForeignPtr mp1 mp2
+ = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
+
+foreign import "eqForeignObj" unsafe
+ primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
+
+instance Eq (ForeignPtr a) where
+ p == q = eqForeignPtr p q
+ p /= q = not (eqForeignPtr p q)
+
+newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a)
+newForeignPtr p finalizer
+ = do fObj <- mkForeignPtr p
+ addForeignPtrFinalizer fObj finalizer
+ return fObj
+
+addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO ()
+addForeignPtrFinalizer (ForeignPtr fo) finalizer =
+ IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) }
+
+mkForeignPtr :: Ptr a -> IO (ForeignPtr a) {- not exported -}
+mkForeignPtr (Ptr obj) = IO ( \ s# ->
+ case mkForeignObj# obj s# of
+ (# s1#, fo# #) -> (# s1#, ForeignPtr fo# #) )
+
+touchForeignPtr :: ForeignPtr a -> IO ()
+touchForeignPtr (ForeignPtr fo)
+ = IO $ \s -> case touch# fo s of s -> (# s, () #)
+
+withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+withForeignPtr fo io
+ = do r <- io (foreignPtrToPtr fo)
+ touchForeignPtr fo
+ return r
+
+foreignPtrToPtr :: ForeignPtr a -> Ptr a
+foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo)
+
+castForeignPtr (ForeignPtr a) = ForeignPtr a
+#endif
+
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Marshal.Alloc
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Alloc.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Marshalling support: basic routines for memory allocation
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Alloc (
+ malloc, -- :: Storable a => IO (Ptr a)
+ mallocBytes, -- :: Int -> IO (Ptr a)
+
+ alloca, -- :: Storable a => (Ptr a -> IO b) -> IO b
+ allocaBytes, -- :: Int -> (Ptr a -> IO b) -> IO b
+
+ reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a)
+
+ free -- :: Ptr a -> IO ()
+) where
+
+import Data.Maybe
+import Foreign.Ptr ( Ptr, nullPtr )
+import Foreign.C.TypesISO ( CSize )
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exception ( bracket )
+import GHC.Storable ( Storable(sizeOf) )
+import GHC.IOBase
+import GHC.Real
+import GHC.Err
+import GHC.Base
+#endif
+
+
+-- exported functions
+-- ------------------
+
+-- allocate space for storable type
+--
+malloc :: Storable a => IO (Ptr a)
+malloc = doMalloc undefined
+ where
+ doMalloc :: Storable a => a -> IO (Ptr a)
+ doMalloc dummy = mallocBytes (sizeOf dummy)
+
+-- allocate given number of bytes of storage
+--
+mallocBytes :: Int -> IO (Ptr a)
+mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size))
+
+-- temporarily allocate space for a storable type
+--
+-- * the pointer passed as an argument to the function must *not* escape from
+-- this function; in other words, in `alloca f' the allocated storage must
+-- not be used after `f' returns
+--
+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)
+
+-- temporarily allocate the given number of bytes of storage
+--
+-- * the pointer passed as an argument to the function must *not* escape from
+-- this function; in other words, in `allocaBytes n f' the allocated storage
+-- must not be used after `f' returns
+--
+allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
+allocaBytes size = bracket (mallocBytes size) free
+
+-- adjust a malloc'ed storage area to the given size
+--
+reallocBytes :: Ptr a -> Int -> IO (Ptr a)
+reallocBytes ptr size =
+ failWhenNULL "realloc" (_realloc ptr (fromIntegral size))
+
+-- free malloc'ed storage
+--
+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
+#ifdef __GLASGOW_HASKELL__
+ then ioException (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 "malloc" unsafe _malloc :: CSize -> IO (Ptr a)
+foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a)
+foreign import "free" unsafe _free :: Ptr a -> IO ()
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Marshal.Array
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Array.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Marshalling support: routines allocating, storing, and retrieving Haskell
+-- lists that are represented as arrays in the foreign language
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Array (
+
+ -- 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
+
+ -- destruction
+ --
+ destructArray, -- :: Storable a => Int -> Ptr a -> IO ()
+ destructArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO ()
+
+ -- 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
+
+#ifdef __GLASGOW_HASKELL__
+import Foreign.Ptr (Ptr, plusPtr)
+import GHC.Storable (Storable(sizeOf,peekElemOff,pokeElemOff,destruct))
+import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)
+import Foreign.Marshal.Utils (copyBytes, moveBytes)
+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
+--
+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 element to signal the end of the array
+--
+mallocArray0 :: Storable a => Int -> IO (Ptr a)
+mallocArray0 size = mallocArray (size + 1)
+
+-- temporarily allocate space for the given number of elements
+--
+-- * see `MarshalAlloc.alloca' for the storage lifetime constraints
+--
+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 element to signal the end of the array
+--
+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 while adding an element 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
+--
+peekArray :: Storable a => Int -> Ptr a -> IO [a]
+peekArray size ptr = mapM (peekElemOff ptr) [0..size-1]
+
+-- 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 = loop 0
+ where
+ loop i = do
+ val <- peekElemOff ptr i
+ if val == marker then return [] else do
+ rest <- loop (i+1)
+ return (val:rest)
+
+-- write the list elements consecutive into memory
+--
+pokeArray :: Storable a => Ptr a -> [a] -> IO ()
+pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals
+
+-- write the list elements consecutive into memory and terminate them with the
+-- given marker element
+--
+pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()
+pokeArray0 marker ptr vals = do
+ pokeArray ptr vals
+ pokeElemOff ptr (length vals) marker
+
+
+-- combined allocation and marshalling
+-- -----------------------------------
+
+-- write a list of storable elements into a newly allocated, consecutive
+-- sequence of storable values
+--
+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
+--
+withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
+withArray vals f =
+ allocaArray len $ \ptr -> do
+ pokeArray ptr vals
+ res <- f ptr
+ destructArray 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 f =
+ allocaArray0 len $ \ptr -> do
+ pokeArray0 marker ptr vals
+ res <- f ptr
+ destructArray (len+1) ptr
+ return res
+ where
+ len = length vals
+
+
+-- destruction
+-- -----------
+
+-- destruct each element of an array (in reverse order)
+--
+destructArray :: Storable a => Int -> Ptr a -> IO ()
+destructArray size ptr =
+ sequence_ [destruct (ptr `advancePtr` i)
+ | i <- [size-1, size-2 .. 0]]
+
+-- like `destructArray', but a terminator indicates where the array ends
+--
+destructArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO ()
+destructArray0 marker ptr = do
+ size <- lengthArray0 marker ptr
+ sequence_ [destruct (ptr `advancePtr` i)
+ | i <- [size, size-1 .. 0]]
+
+
+-- 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 -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Marshal.Error
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Error.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Marshalling support: Handling of common error conditions
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Error (
+
+ -- throw an exception on specific return values
+ --
+ 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__
+import GHC.Base
+import GHC.Num
+import GHC.IOBase
+#endif
+
+-- exported functions
+-- ------------------
+
+-- guard an IO operation and throw an exception if the result meets the given
+-- predicate
+--
+-- * the second argument computes an error message from the result of the IO
+-- operation
+--
+throwIf :: (a -> Bool) -> (a -> String) -> IO a -> 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 -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Marshal.Utils
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Utils.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Utilities for primitive marshaling
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Utils (
+
+ -- combined allocation and marshalling
+ --
+ withObject, -- :: Storable a => a -> (Ptr a -> IO b) -> IO b
+ {- FIXME: should be `with' -}
+ 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
+
+#ifdef __GLASGOW_HASKELL__
+import Foreign.Ptr ( Ptr, nullPtr )
+import GHC.Storable ( Storable(poke,destruct) )
+import Foreign.C.TypesISO ( CSize )
+import Foreign.Marshal.Alloc ( malloc, alloca )
+import GHC.IOBase
+import GHC.Real ( fromIntegral )
+import GHC.Num
+import GHC.Base
+#endif
+
+-- combined allocation and marshalling
+-- -----------------------------------
+
+-- allocate storage for a value and marshal it into this storage
+--
+new :: Storable a => a -> IO (Ptr a)
+new val =
+ do
+ ptr <- malloc
+ poke ptr val
+ return ptr
+
+-- allocate temporary storage for a value and marshal it into this storage
+--
+-- * see the life time constraints imposed by `alloca'
+--
+{- FIXME: should be called `with' -}
+withObject :: Storable a => a -> (Ptr a -> IO b) -> IO b
+withObject val f =
+ alloca $ \ptr -> do
+ poke ptr val
+ res <- f ptr
+ destruct ptr
+ return res
+
+
+-- marshalling of Boolean values (non-zero corresponds to `True')
+-- -----------------------------
+
+-- convert a Haskell Boolean 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'
+--
+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 = memcpy dest src (fromIntegral size)
+
+-- copies the given number of elements 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 = memmove dest src (fromIntegral size)
+
+
+-- auxilliary routines
+-- -------------------
+
+-- basic C routines needed for memory copying
+--
+foreign import unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO ()
+foreign import unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO ()
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Ptr
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Ptr.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Pointer types.
+--
+-----------------------------------------------------------------------------
+
+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.
+
+ ) where
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Ptr
+import GHC.IOBase
+import GHC.Err
+#endif
+
+foreign import "freeHaskellFunctionPtr" unsafe
+ freeHaskellFunPtr :: FunPtr a -> IO ()
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.StablePtr
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: StablePtr.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- Stable pointers.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.StablePtr
+ ( StablePtr, -- abstract
+ , newStablePtr -- :: a -> IO (StablePtr a)
+ , deRefStablePtr -- :: StablePtr a -> IO a
+ , freeStablePtr -- :: StablePtr a -> IO ()
+ , castStablePtrToPtr -- :: StablePtr a -> Ptr ()
+ , castPtrToStablePtr -- :: Ptr () -> StablePtr a
+ ) where
+
+import Data.Dynamic
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Stable
+import GHC.Err
+#endif
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Foreign.Storable
+-- Copyright : (c) The FFI task force 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : ffi@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Storable.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- A class for primitive marshaling
+--
+-----------------------------------------------------------------------------
+
+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 ()
+ destruct) -- :: Ptr a -> IO ()
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Storable
+#endif
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Arr.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Arr]{Module @GHC.Arr@}
+
+Array implementation, @GHC.Arr@ exports the basic array
+types and operations.
+
+For byte-arrays see @GHC.ByteArr@.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+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}
+class (Ord a) => Ix a where
+ range :: (a,a) -> [a]
+ index, unsafeIndex :: (a,a) -> a -> Int
+ inRange :: (a,a) -> a -> Bool
+
+ -- 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
+\end{code}
+
+
+%*********************************************************
+%* *
+\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{Size of @Ix@ interval}
+%* *
+%********************************************************
+
+The @rangeSize@ operator returns the number of elements
+in the range for an @Ix@ pair.
+
+\begin{code}
+{-# SPECIALISE unsafeRangeSize :: (Int,Int) -> Int #-}
+{-# SPECIALISE unsafeRangeSize :: ((Int,Int),(Int,Int)) -> Int #-}
+unsafeRangeSize :: (Ix a) => (a,a) -> Int
+unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1
+
+{-# SPECIALISE rangeSize :: (Int,Int) -> Int #-}
+{-# SPECIALISE rangeSize :: ((Int,Int),(Int,Int)) -> Int #-}
+rangeSize :: (Ix a) => (a,a) -> Int
+rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
+ | otherwise = 0
+
+-- 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
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Array@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+type IPr = (Int, Int)
+
+data Ix i => Array i e = Array !i !i (Array# e)
+data Ix i => STArray s i e = STArray !i !i (MutableArray# s e)
+
+-- 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"
+
+{-# INLINE array #-}
+array :: Ix i => (i,i) -> [(i, e)] -> 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.
+
+{-# 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# }}})
+
+{-# 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
+
+{-# INLINE bounds #-}
+bounds :: Ix i => Array i e -> (i,i)
+bounds (Array l u _) = (l,u)
+
+{-# INLINE indices #-}
+indices :: Ix i => Array i e -> [i]
+indices (Array l u _) = range (l,u)
+
+{-# INLINE elems #-}
+elems :: Ix i => Array i e -> [e]
+elems arr@(Array l u _) =
+ [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]]
+
+{-# 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)]
+
+{-# INLINE accumArray #-}
+accumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(i, a)] -> 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# }}
+
+{-# 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))
+
+{-# 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]]
+
+{-# 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 > 9) $
+ showString "array " .
+ shows (bounds a) .
+ showChar ' ' .
+ shows (assocs a)
+
+{-
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+-}
+\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
+% -----------------------------------------------------------------------------
+% $Id: Base.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+\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
+
+ Classes: CCallable, CReturnable
+
+GHC.Base Classes: Eq, Ord, Functor, Monad
+ Types: list, (), Int, Bool, Ordering, Char, String
+
+GHC.Tup 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
+
+GHC.Maybe Type: Maybe, plus instances for GHC.Base classes
+
+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
+
+Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples
+
+GHC.Arr Types: Array, MutableArray, MutableVar
+
+ Does *not* contain any ByteArray stuff (see GHC.ByteArr)
+ 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
+
+GHC.ByteArr Types: ByteArray, MutableByteArray
+
+ We want this one to be after GHC.Float, because it defines arrays
+ of unboxed floats.
+
+
+Other Prelude modules are much easier with fewer complex dependencies.
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#include "MachDeps.h"
+
+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}
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ x /= y = not (x == y)
+ x == y = not (x /= y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>), (>=) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+ -- An instance of Ord should define either 'compare' or '<='.
+ -- Using 'compare' can be more efficient for complex types.
+
+ 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}
+class Functor f where
+ fmap :: (a -> b) -> f a -> f b
+
+class Monad m where
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ return :: a -> m a
+ 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 :: (a -> b -> b) -> b -> [a] -> b
+-- foldr _ z [] = z
+-- foldr f z (x:xs) = f x (foldr f z xs)
+{-# INLINE foldr #-}
+foldr k z xs = go xs
+ where
+ go [] = z
+ go (y:ys) = y `k` go ys
+
+build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a]
+{-# INLINE 2 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 "2" says to inline in phase 2
+
+build g = g (:) []
+
+augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a]
+{-# INLINE 2 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" forall xs ys. foldr (:) ys xs = append xs ys
+
+"foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs)
+"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 :: (a -> b) -> [a] -> [b]
+map = mapList
+
+-- Note eta expanded
+mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst
+mapFB c f x ys = c (f x) ys
+
+mapList :: (a -> b) -> [a] -> [b]
+mapList _ [] = []
+mapList f (x:xs) = f x : mapList f xs
+
+{-# RULES
+"map" forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs)
+"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g)
+"mapList" forall f. foldr (mapFB (:) f) [] = mapList f
+ #-}
+\end{code}
+
+
+----------------------------------------------
+-- append
+----------------------------------------------
+\begin{code}
+(++) :: [a] -> [a] -> [a]
+(++) = append
+
+{-# RULES
+"++" forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys
+ #-}
+
+append :: [a] -> [a] -> [a]
+append [] ys = ys
+append (x:xs) ys = x : append xs ys
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Bool@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Bool = False | True deriving (Eq, Ord)
+ -- Read in GHC.Read, Show in GHC.Show
+
+-- Boolean functions
+
+(&&), (||) :: Bool -> Bool -> Bool
+True && x = x
+False && _ = False
+True || _ = True
+False || x = x
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+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}
+data () = ()
+
+instance Eq () where
+ () == () = True
+ () /= () = False
+
+instance Ord () where
+ () <= () = True
+ () < () = False
+ () >= () = True
+ () > () = False
+ max () () = ()
+ min () () = ()
+ compare () () = EQ
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Ordering@}
+%* *
+%*********************************************************
+
+\begin{code}
+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}
+type String = [Char]
+
+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
+ #-}
+
+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#)
+
+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 = (==)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Int@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Int = I# Int#
+
+zeroInt, oneInt, twoInt, maxInt, minInt :: Int
+zeroInt = I# 0#
+oneInt = I# 1#
+twoInt = I# 2#
+#if WORD_SIZE_IN_BYTES == 4
+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
+
+-- 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
+
+-- right-associating infix application operator (useful in continuation-
+-- passing style)
+{-# 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{CCallable instances}
+%* *
+%*********************************************************
+
+Defined here to avoid orphans
+
+\begin{code}
+instance CCallable Char
+instance CReturnable Char
+
+instance CCallable Int
+instance CReturnable Int
+
+instance CReturnable () -- Why, exactly?
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Generics}
+%* *
+%*********************************************************
+
+\begin{code}
+data Unit = Unit
+data a :+: b = Inl a | Inr b
+data a :*: b = a :*: b
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Numeric primops}
+%* *
+%*********************************************************
+
+\begin{code}
+divInt#, modInt# :: Int# -> Int# -> Int#
+x# `divInt#` y#
+ | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y#
+ | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y#
+ | otherwise = x# `quotInt#` y#
+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
+ #-}
+
+#if WORD_SIZE_IN_BYTES == 4
+{-# RULES
+"intToInt32#" forall x#. intToInt32# x# = x#
+"wordToWord32#" forall x#. wordToWord32# 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]
+unpackCString# a = unpackCStringList# a
+
+unpackCStringList# :: Addr# -> [Char]
+unpackCStringList# 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
+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#) `iShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) :
+ unpack (nh +# 2#)
+ | ch `leChar#` '\xEF'# =
+ C# (chr# ((ord# ch -# 0xE0#) `iShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 6# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) :
+ unpack (nh +# 3#)
+ | otherwise =
+ C# (chr# ((ord# ch -# 0xF0#) `iShiftL#` 18# +#
+ (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +#
+ (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#` 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" forall a . unpackCString# a = build (unpackFoldrCString# a)
+"unpack-list" forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a
+"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n
+
+-- There's a built-in rule (in GHC.Rules.lhs) for
+-- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n
+
+ #-}
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: ByteArr.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.ByteArr]{Module @GHC.ByteArr@}
+
+Byte-arrays are flat arrays of non-pointers only.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.ByteArr where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Num
+import GHC.Arr
+import GHC.Float
+import GHC.ST
+import GHC.Base
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Array@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+data Ix ix => ByteArray ix = ByteArray ix ix ByteArray#
+data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+
+instance CCallable (ByteArray ix)
+instance CCallable (MutableByteArray RealWorld ix)
+ -- Note the RealWorld! You can only ccall with MutableByteArray args
+ -- which are in the real world. When this was missed out, the result
+ -- was that a CCallOpId had a free tyvar, and since the compiler doesn't
+ -- expect that it didn't get zonked or substituted. Bad news.
+
+instance Eq (MutableByteArray s ix) where
+ MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2#
+ = sameMutableByteArray# arr1# arr2#
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Operations on mutable arrays}
+%* *
+%*********************************************************
+
+\begin{code}
+newCharArray, newIntArray, newFloatArray, newDoubleArray
+ :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix)
+
+{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-}
+{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
+
+newCharArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newByteArray# (cHAR_SCALE n#) s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newIntArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newWordArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newFloatArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newByteArray# (fLOAT_SCALE n#) s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+newDoubleArray (l,u) = ST $ \ s# ->
+ case rangeSize (l,u) of { I# n# ->
+ case (newByteArray# (dOUBLE_SCALE n#) s#) of { (# s2#, barr# #) ->
+ (# s2#, MutableByteArray l u barr# #) }}
+
+#include "config.h"
+
+ -- Char arrays really contain only 8-bit bytes for compatibility.
+cHAR_SCALE n = 1# *# n
+wORD_SCALE n = (case SIZEOF_VOID_P :: Int of I# x -> x *# n)
+dOUBLE_SCALE n = (case SIZEOF_DOUBLE :: Int of I# x -> x *# n)
+fLOAT_SCALE n = (case SIZEOF_FLOAT :: Int of I# x -> x *# n)
+
+readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
+readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
+readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float
+readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double
+
+{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-}
+{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-}
+--NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-}
+{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
+
+readCharArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readCharArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, C# r# #) }}
+
+readIntArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readIntArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, I# r# #) }}
+
+readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readFloatArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, F# r# #) }}
+
+readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# ->
+ case (index (l,u) n) of { I# n# ->
+ case readDoubleArray# barr# n# s# of { (# s2#, r# #) ->
+ (# s2#, D# r# #) }}
+
+--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
+indexCharArray :: Ix ix => ByteArray ix -> ix -> Char
+indexIntArray :: Ix ix => ByteArray ix -> ix -> Int
+indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float
+indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double
+
+{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-}
+{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-}
+--NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-}
+{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
+
+indexCharArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexCharArray# barr# n# of { r# ->
+ (C# r#)}}
+
+indexIntArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexIntArray# barr# n# of { r# ->
+ (I# r#)}}
+
+indexFloatArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexFloatArray# barr# n# of { r# ->
+ (F# r#)}}
+
+indexDoubleArray (ByteArray l u barr#) n
+ = case (index (l,u) n) of { I# n# ->
+ case indexDoubleArray# barr# n# of { r# ->
+ (D# r#)}}
+
+writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
+writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
+writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s ()
+writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s ()
+
+{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-}
+{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-}
+--NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
+{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
+
+writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeCharArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeIntArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeFloatArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+
+writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# ->
+ case index (l,u) n of { I# n# ->
+ case writeDoubleArray# barr# n# ele s# of { s2# ->
+ (# s2#, () #) }}
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Conc.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Conc]{Module @GHC.Conc@}
+
+Basic concurrency stuff
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Conc
+ ( ThreadId(..)
+
+ -- Forking and suchlike
+ , myThreadId -- :: IO ThreadId
+ , killThread -- :: ThreadId -> IO ()
+ , throwTo -- :: ThreadId -> Exception -> IO ()
+ , par -- :: a -> b -> b
+ , seq -- :: a -> b -> b
+ , yield -- :: IO ()
+
+ -- Waiting
+ , threadDelay -- :: Int -> IO ()
+ , 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 ()
+
+ ) where
+
+import GHC.Base
+import GHC.Maybe
+import GHC.Err ( parError, seqError )
+import GHC.IOBase ( IO(..), MVar(..) )
+import GHC.Base ( Int(..) )
+import GHC.Exception ( Exception(..), AsyncException(..) )
+
+infixr 0 `par`, `seq`
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@ThreadId@, @par@, and @fork@}
+%* *
+%************************************************************************
+
+\begin{code}
+data ThreadId = ThreadId ThreadId#
+-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
+-- But since ThreadId# is unlifted, the Weak type must use open
+-- type variables.
+
+--forkIO has now been hoisted out into the Concurrent library.
+
+killThread :: ThreadId -> IO ()
+killThread (ThreadId id) = IO $ \ s ->
+ case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
+
+throwTo :: ThreadId -> Exception -> IO ()
+throwTo (ThreadId id) ex = IO $ \ s ->
+ case (killThread# id ex s) of s1 -> (# s1, () #)
+
+myThreadId :: IO ThreadId
+myThreadId = IO $ \s ->
+ case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #)
+
+yield :: IO ()
+yield = IO $ \s ->
+ case (yield# s) of s1 -> (# s1, () #)
+
+-- "seq" is defined a bit weirdly (see below)
+--
+-- The reason for the strange "0# -> parError" case is that
+-- it fools the compiler into thinking that seq is non-strict in
+-- its second argument (even if it inlines seq at the call site).
+-- If it thinks seq is strict in "y", then it often evaluates
+-- "y" before "x", which is totally wrong.
+--
+-- Just before converting from Core to STG there's a bit of magic
+-- that recognises the seq# and eliminates the duff case.
+
+{-# INLINE seq #-}
+seq :: a -> b -> b
+seq x y = case (seq# x) of { 0# -> seqError; _ -> y }
+
+{-# INLINE par #-}
+par :: a -> b -> b
+par x y = case (par# x) of { 0# -> parError; _ -> y }
+\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)
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = IO $ \ s# ->
+ case newMVar# s# of
+ (# s2#, svar# #) -> (# s2#, MVar svar# #)
+
+takeMVar :: MVar a -> IO a
+takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#
+
+putMVar :: MVar a -> a -> IO ()
+putMVar (MVar mvar#) x = IO $ \ s# ->
+ case putMVar# mvar# x s# of
+ s2# -> (# s2#, () #)
+
+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 #)
+
+newMVar :: a -> IO (MVar a)
+newMVar value =
+ newEmptyMVar >>= \ mvar ->
+ putMVar mvar value >>
+ return mvar
+
+-- tryTakeMVar is a non-blocking takeMVar
+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
+
+{-
+ Low-level op. for checking whether an MVar is filled-in or not.
+ 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.
+
+ If you can re-work your abstractions to avoid having to
+ depend on isEmptyMVar, then you're encouraged to do so,
+ i.e., consider yourself warned about the imprecision in
+ general of isEmptyMVar :-)
+-}
+isEmptyMVar :: MVar a -> IO Bool
+isEmptyMVar (MVar mv#) = IO $ \ s# ->
+ case isEmptyMVar# mv# s# of
+ (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #)
+
+-- Like addForeignPtrFinalizer, but for MVars
+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}
+%* *
+%************************************************************************
+
+@threadDelay@ delays rescheduling of a thread until the indicated
+number of microseconds have elapsed. Generally, the microseconds are
+counted by the context switch timer, which ticks in virtual time;
+however, when there are no runnable threads, we don't accumulate any
+virtual time, so we start ticking in real time. (The granularity is
+the effective resolution of the context switch timer, so it is
+affected by the RTS -C option.)
+
+@threadWaitRead@ delays rescheduling of a thread until input on the
+specified file descriptor is available for reading (just like select).
+@threadWaitWrite@ is similar, but for writing on a file descriptor.
+
+\begin{code}
+threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
+
+threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #)
+threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #)
+threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #)
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Dynamic.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1998-2000
+%
+
+The Dynamic type is used in the Exception type, so we have to have
+Dynamic visible here. The rest of the operations on Dynamics are
+available in lang/Dynamic.lhs.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#ifndef __HUGS__
+module GHC.Dynamic where
+
+import GHC.Base
+#endif
+
+data Dynamic = Dynamic TypeRep Obj
+
+data Obj = Obj
+ -- dummy type to hold the dynamically typed value.
+
+data TypeRep
+ = App TyCon [TypeRep]
+ | Fun TypeRep TypeRep
+ deriving ( Eq )
+
+-- type constructors are
+data TyCon = TyCon Int String
+
+instance Eq TyCon where
+ (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Enum.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+
+\section[GHC.Bounded]{Module @GHC.Bounded@}
+
+Instances of Bounded for various datatypes.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Enum(
+ Bounded(..), Enum(..),
+ boundedEnumFrom, boundedEnumFromThen,
+
+ -- Instances for Bounded and Eum: (), Char, Int
+
+ ) where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Base
+import GHC.Tup () -- To make sure we look for the .hi file
+
+default () -- Double isn't available yet
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Class declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+class Bounded a where
+ minBound, maxBound :: a
+
+class Enum a where
+ succ, pred :: a -> a
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,n'..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ 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 argment"
+ pred _ = error "Prelude.Enum.().pred: bad argument"
+
+ toEnum x | x == zeroInt = ()
+ | otherwise = error "Prelude.Enum.().toEnum: bad argument"
+
+ fromEnum () = zeroInt
+ enumFrom () = [()]
+ enumFromThen () () = [()]
+ enumFromTo () () = [()]
+ enumFromThenTo () () () = [()]
+\end{code}
+
+\begin{code}
+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)
+\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 argment"
+
+ pred True = False
+ pred False = error "Prelude.Enum.Bool.pred: bad argment"
+
+ toEnum n | n == zeroInt = False
+ | n == oneInt = True
+ | otherwise = error "Prelude.Enum.Bool.toEnum: bad argment"
+
+ 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 argment"
+
+ pred GT = EQ
+ pred EQ = LT
+ pred LT = error "Prelude.Enum.Ordering.pred: bad argment"
+
+ toEnum n | n == zeroInt = LT
+ | n == oneInt = EQ
+ | n == twoInt = GT
+ toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argment"
+
+ 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)
+
+eftChar = eftCharList
+efdChar = efdCharList
+efdtChar = efdtCharList
+
+
+{-# RULES
+"eftChar" forall x y. eftChar x y = build (\c n -> eftCharFB c n x y)
+"efdChar" forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2)
+"efdtChar" forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l)
+"eftCharList" eftCharFB (:) [] = eftCharList
+"efdCharList" efdCharFB (:) [] = efdCharList
+"efdtCharList" efdtCharFB (:) [] = efdtCharList
+ #-}
+
+
+-- We can do better than for Ints because we don't
+-- have hassles about arithmetic overflow at maxBound
+{-# INLINE eftCharFB #-}
+eftCharFB c n x y = go x
+ where
+ go x | x ># y = n
+ | otherwise = C# (chr# x) `c` go (x +# 1#)
+
+eftCharList x y | x ># y = []
+ | otherwise = C# (chr# x) : eftCharList (x +# 1#) y
+
+
+-- For enumFromThenTo we give up on inlining
+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
+
+efdCharList x1 x2
+ | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF#
+ | otherwise = go_dn_char_list x1 delta 0#
+ where
+ delta = x2 -# x1
+
+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
+
+efdtCharList 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 2147483647#
+ -- 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 = eftIntList
+efdInt = efdIntList
+efdtInt = efdtIntList
+
+{-# RULES
+"eftInt" forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
+"efdInt" forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2)
+"efdtInt" forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l)
+
+"eftIntList" eftIntFB (:) [] = eftIntList
+"efdIntList" efdIntFB (:) [] = efdIntList
+"efdtIntList" efdtIntFB (:) [] = efdtIntList
+ #-}
+
+
+{-# INLINE eftIntFB #-}
+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"
+
+eftIntList x y | x ># y = []
+ | otherwise = go x
+ where
+ go x = I# x : if x ==# y then [] else go (x +# 1#)
+
+
+-- For enumFromThenTo we give up on inlining; so we don't worry
+-- about duplicating occurrences of "c"
+efdtIntFB c n x1 x2 y
+ | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim
+ | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim
+ where
+ delta = x2 -# x1
+ lim = y -# delta
+
+efdtIntList x1 x2 y
+ | delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim
+ | otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim
+ where
+ delta = x2 -# x1
+ lim = y -# delta
+
+efdIntFB c n x1 x2
+ | delta >=# 0# = go_up_int_fb c n x1 delta ( 2147483647# -# delta)
+ | otherwise = go_dn_int_fb c n x1 delta ((-2147483648#) -# delta)
+ where
+ delta = x2 -# x1
+
+efdIntList x1 x2
+ | delta >=# 0# = go_up_int_list x1 delta ( 2147483647# -# delta)
+ | otherwise = go_dn_int_list x1 delta ((-2147483648#) -# delta)
+ where
+ delta = x2 -# x1
+
+-- In all of these, the (x +# delta) is guaranteed not to overflow
+
+go_up_int_fb c n x delta lim
+ = go_up x
+ where
+ go_up x | x ># lim = I# x `c` n
+ | otherwise = I# x `c` go_up (x +# delta)
+
+go_dn_int_fb c n x delta lim
+ = go_dn x
+ where
+ go_dn x | x <# lim = I# x `c` n
+ | otherwise = I# x `c` go_dn (x +# delta)
+
+go_up_int_list x delta lim
+ = go_up x
+ where
+ go_up x | x ># lim = [I# x]
+ | otherwise = I# x : go_up (x +# delta)
+
+go_dn_int_list x delta lim
+ = go_dn x
+ where
+ go_dn x | x <# lim = [I# x]
+ | otherwise = I# x : go_dn (x +# delta)
+\end{code}
+
--- /dev/null
+---------------------------------------------------------------------------
+-- PrelErr.hi-boot
+--
+-- This hand-written interface file is the initial bootstrap version
+-- for PrelErr.hi.
+-- It doesn't need to give "error" a type signature,
+-- because it's wired into the compiler
+---------------------------------------------------------------------------
+
+__interface "std" GHCziErr 1 where
+__export GHCziErr error parError;
+
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Err.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Err]{Module @GHC.Err@}
+
+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.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+module GHC.Err
+ (
+ irrefutPatError
+ , noMethodBindingError
+ , nonExhaustiveGuardsError
+ , patError
+ , recSelError
+ , recConError
+ , recUpdError -- :: String -> a
+
+ , absentErr, parError -- :: a
+ , seqError -- :: a
+
+ , error -- :: String -> a
+ , assertError -- :: String -> Bool -> a -> a
+
+ , undefined -- :: a
+ ) where
+
+import GHC.Base
+import GHC.List ( span )
+import GHC.Exception
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Error-ish functions}
+%* *
+%*********************************************************
+
+\begin{code}
+-- error stops execution and displays an error message
+error :: String -> a
+error s = throw (ErrorCall s)
+
+-- 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, parError, seqError :: a
+
+absentErr = error "Oops! The program has entered an `absent' argument!\n"
+parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
+seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
+
+\end{code}
+
+\begin{code}
+irrefutPatError
+ , noMethodBindingError
+ , nonExhaustiveGuardsError
+ , patError
+ , recSelError
+ , recConError
+ , recUpdError :: String -> a
+
+noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
+irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in"))
+patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
+recConError s = throw (RecConError (untangle s "Missing field in record construction"))
+recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
+
+
+assertError :: String -> 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 :: String -> String -> String
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
+ ++ "\n"
+ where
+ (location, details)
+ = case (span not_bar coded) of { (loc, rest) ->
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
+ not_bar c = c /= '|'
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Exception.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1998-2000
+%
+
+Exceptions and exception-handling functions.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#ifndef __HUGS__
+module GHC.Exception
+ ( module GHC.Exception,
+ Exception(..), AsyncException(..),
+ IOException(..), ArithException(..), ArrayException(..),
+ throw, ioError )
+ where
+
+import GHC.Base
+import GHC.Maybe
+import GHC.IOBase
+
+#endif
+\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
+#ifdef __HUGS__
+catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s)
+#else
+catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s
+#endif
+
+catch :: IO a -> (Exception -> IO a) -> IO a
+catch m k = catchException m handler
+ where handler err@(IOException _) = k err
+ handler err@(UserError _) = k err
+ handler other = throw other
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Try and bracket}
+%* *
+%*********************************************************
+
+The construct @try comp@ exposes errors which occur within a
+computation, and which are not fully handled. It always succeeds.
+
+These are the IO-only try/bracket. For the full exception try/bracket
+see hslibs/lang/Exception.lhs.
+
+\begin{code}
+try :: IO a -> IO (Either Exception a)
+try f = catch (do r <- f
+ return (Right r))
+ (return . Left)
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+ x <- before
+ rs <- try (m x)
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
+
+-- variant of the above where middle computation doesn't want x
+bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+ x <- before
+ rs <- try m
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Controlling asynchronous exception delivery}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifndef __HUGS__
+block :: IO a -> IO a
+block (IO io) = IO $ blockAsyncExceptions# io
+
+unblock :: IO a -> IO a
+unblock (IO io) = IO $ unblockAsyncExceptions# io
+#else
+-- Not implemented yet in Hugs.
+block :: IO a -> IO a
+block (IO io) = IO io
+
+unblock :: IO a -> IO a
+unblock (IO io) = IO io
+#endif
+\end{code}
+
+
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Float.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Num]{Module @GHC.Num@}
+
+The types
+
+ Float
+ Double
+
+and the classes
+
+ Floating
+ RealFloat
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#include "ieee-flpt.h"
+
+module GHC.Float( module GHC.Float, Float#, Double# ) where
+
+import GHC.Base
+import GHC.List
+import GHC.Enum
+import GHC.Show
+import GHC.Num
+import GHC.Real
+import GHC.Arr
+import GHC.Maybe
+
+infixr 8 **
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Standard numeric classes}
+%* *
+%*********************************************************
+
+\begin{code}
+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
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> Integer
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (Integer,Int)
+ encodeFloat :: Integer -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+ 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}
+data Float = F# Float#
+data Double = D# Double#
+
+instance CCallable Float
+instance CReturnable Float
+
+instance CCallable Double
+instance CReturnable 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 n = encodeFloat n 0
+ -- It's important that encodeFloat inlines here, and that
+ -- fromInteger in turn inlines,
+ -- so that if fromInteger is applied to an (S# i) the right thing happens
+
+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 ceiling :: Float -> Int #-}
+ {-# SPECIALIZE floor :: Float -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Integer #-}
+ {-# SPECIALIZE round :: Float -> Integer #-}
+ {-# SPECIALIZE ceiling :: Float -> Integer #-}
+ {-# SPECIALIZE floor :: Float -> Integer #-}
+
+ 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 ceiling :: Double -> Int #-}
+ {-# SPECIALIZE floor :: Double -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Integer #-}
+ {-# SPECIALIZE round :: Double -> Integer #-}
+ {-# SPECIALIZE ceiling :: Double -> Integer #-}
+ {-# SPECIALIZE floor :: Double -> Integer #-}
+
+ 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}
+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 ->
+ 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 : '.' : 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.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+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 =
+ let
+ 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}
+{-# SPECIALISE fromRat ::
+ Rational -> Double,
+ Rational -> Float #-}
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x
+ | x == 0 = encodeFloat 0 0 -- Handle exceptional cases
+ | x < 0 = - fromRat' (-x) -- first.
+ | otherwise = fromRat' x
+
+-- 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
+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 "__encodeFloat" unsafe
+ encodeFloat# :: Int# -> ByteArray# -> Int -> Float
+foreign import ccall "__int_encodeFloat" unsafe
+ int_encodeFloat# :: Int# -> Int -> Float
+
+
+foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int
+foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int
+foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int
+foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int
+
+
+foreign import ccall "__encodeDouble" unsafe
+ encodeDouble# :: Int# -> ByteArray# -> Int -> Double
+foreign import ccall "__int_encodeDouble" unsafe
+ int_encodeDouble# :: Int# -> Int -> Double
+
+foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int
+foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int
+foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int
+foreign import ccall "isDoubleNegativeZero" unsafe 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 -fno-implicit-prelude #-}
+
+#undef DEBUG_DUMP
+#undef DEBUG
+
+-- -----------------------------------------------------------------------------
+-- $Id: Handle.hsc,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2001
+--
+-- This module defines the basic operations on I/O "handles".
+
+module GHC.Handle (
+ withHandle, withHandle', withHandle_,
+ wantWritableHandle, wantReadableHandle, wantSeekableHandle,
+
+ newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+ read_off,
+
+ ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
+
+ stdin, stdout, stderr,
+ IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
+ hClose, hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFlush,
+
+ HandlePosn(..), hGetPosn, hSetPosn,
+ SeekMode(..), hSeek,
+
+ hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
+ hSetEcho, hGetEcho, hIsTerminalDevice,
+ ioeGetFileName, ioeGetErrorString, ioeGetHandle,
+
+#ifdef DEBUG_DUMP
+ puts,
+#endif
+
+ ) where
+
+#include "HsCore.h"
+
+import Control.Monad
+import Data.Bits
+import Data.Maybe
+import Foreign
+import Foreign.C
+
+import GHC.Posix
+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 )
+
+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 :: Bool
+dEFAULT_OPEN_IN_BINARY_MODE = False
+
+-- ---------------------------------------------------------------------------
+-- Creating a new handle
+
+newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle finalizer hc = do
+ m <- newMVar hc
+ addMVarFinalizer m (finalizer m)
+ return (FileHandle 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 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',v) <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ 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_' fun h m act =
+ block $ do
+ h_ <- takeMVar m
+ checkBufferInvariants h_
+ v <- catchException (act h_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ 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_)
+ (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ checkBufferInvariants h'
+ putMVar m h'
+ return ()
+
+augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
+ = IOException (IOError (Just h) iot fun str filepath)
+ where filepath | Just _ <- fp = fp
+ | otherwise = Just (haFilePath h_)
+augmentIOError other_exception _ _ _
+ = other_exception
+
+-- ---------------------------------------------------------------------------
+-- 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_) 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_ -> 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 are only allowed on binary-mode handles" Nothing)
+
+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 haType field of the read side be ReadSideHandle with a pointer
+-- to the write side. The finalizer is then placed on the write side, and
+-- the handle only gets finalized once, when both sides are no longer
+-- required.
+
+stdHandleFinalizer :: MVar Handle__ -> IO ()
+stdHandleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+
+handleFinalizer :: MVar Handle__ -> IO ()
+handleFinalizer m = do
+ h_ <- takeMVar m
+ flushWriteBufferOnly h_
+ let fd = fromIntegral (haFD h_)
+ unlockFile fd
+ -- ToDo: closesocket() for a WINSOCK socket?
+ when (fd /= -1) (c_close fd >> return ())
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- 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 ->
+ case newByteArray## size s of { (## s, b ##) ->
+ (## 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##)) ##)
+
+dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int
+
+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 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_) 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 (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR))
+ return buf{ bufWPtr=0, bufRPtr=0 }
+
+flushWriteBuffer :: FD -> Buffer -> IO Buffer
+flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+ 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 <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
+ (write_off (fromIntegral fd) b (fromIntegral r)
+ (fromIntegral bytes))
+ (threadWaitWrite fd)
+ let res' = fromIntegral res
+ if res' < bytes
+ then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
+ else return buf{ bufRPtr=0, bufWPtr=0 }
+
+foreign import "write_wrap" unsafe
+ write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int write_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return write(fd, ptr + off, size); }
+
+
+fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBuffer fd is_line
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+ fillReadBufferLoop fd is_line 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 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 <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
+ (read_off fd b (fromIntegral w) (fromIntegral bytes))
+ (threadWaitRead fd)
+ 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 buf b (w+res') size
+ else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+foreign import "read_wrap" unsafe
+ read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int read_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return read(fd, ptr + off, size); }
+
+-- ---------------------------------------------------------------------------
+-- 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
+
+stdin :: Handle
+stdin = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ setNonBlockingFD fd_stdin
+ (buf, bmode) <- getBuffer fd_stdin ReadBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdin,
+ haType = ReadHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = bmode,
+ haFilePath = "<stdin>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stdout :: Handle
+stdout = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stdout
+ (buf, bmode) <- getBuffer fd_stdout WriteBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stdout,
+ haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = bmode,
+ haFilePath = "<stdout>",
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+stderr :: Handle
+stderr = unsafePerformIO $ do
+ -- ToDo: acquire lock
+ -- We don't set non-blocking mode on stdout or sterr, because
+ -- some shells don't recover properly.
+ -- setNonBlockingFD fd_stderr
+ buffer <- mkUnBuffer
+ spares <- newIORef BufferListNil
+ newFileHandle stdHandleFinalizer
+ (Handle__ { haFD = fd_stderr,
+ haType = WriteHandle,
+ haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
+ haBufferMode = NoBuffering,
+ haFilePath = "<stderr>",
+ haBuffer = buffer,
+ haBuffers = spares
+ })
+
+-- ---------------------------------------------------------------------------
+-- Opening and Closing Files
+
+{-
+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. 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).
+
+Implementations should enforce, locally to the Haskell process,
+multiple-reader single-writer locking on files, which is to say that
+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.
+
+Two files are the same if they have the same absolute name. An
+implementation is free to impose stricter conditions.
+-}
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+data IOModeEx
+ = BinaryMode IOMode
+ | TextMode IOMode
+ deriving (Eq, Read, Show)
+
+addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
+ = IOException (IOError h iot fun str (Just fp))
+addFilePathToIOError _ _ other_exception
+ = other_exception
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp im =
+ catch
+ (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
+ then BinaryMode im
+ else TextMode im))
+ (\e -> throw (addFilePathToIOError "openFile" fp e))
+
+openFileEx :: FilePath -> IOModeEx -> IO Handle
+openFileEx fp m =
+ catch
+ (openFile' fp m)
+ (\e -> throw (addFilePathToIOError "openFileEx" fp e))
+
+
+openFile' filepath ex_mode =
+ withCString filepath $ \ f ->
+
+ let
+ (mode, binary) =
+ case ex_mode of
+ BinaryMode bmo -> (bmo, True)
+ TextMode tmo -> (tmo, False)
+
+ oflags1 = case mode of
+ ReadMode -> read_flags
+ WriteMode -> write_flags
+ ReadWriteMode -> rw_flags
+ AppendMode -> append_flags
+
+ binary_flags
+#ifdef HAVE_O_BINARY
+ | binary = o_BINARY
+#endif
+ | 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 <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "openFile"
+ (c_open f (fromIntegral oflags) 0o666)
+
+ openFd fd filepath mode binary
+
+
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+read_flags = std_flags .|. o_RDONLY
+write_flags = output_flags .|. o_WRONLY .|. o_TRUNC
+rw_flags = output_flags .|. o_RDWR
+append_flags = output_flags .|. o_WRONLY .|. o_APPEND
+
+-- ---------------------------------------------------------------------------
+-- openFd
+
+openFd :: FD -> FilePath -> IOMode -> Bool -> IO Handle
+openFd fd filepath mode binary = do
+ -- turn on non-blocking mode
+ setNonBlockingFD fd
+
+ 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 <- fdType fd
+ case fd_type of
+ Directory ->
+ ioException (IOError Nothing InappropriateType "openFile"
+ "is a directory" Nothing)
+
+ Stream
+ | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
+ | otherwise -> mkFileHandle fd filepath ha_type binary
+
+ -- regular files need to be locked
+ RegularFile -> do
+ r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+ when (r == -1) $
+ ioException (IOError Nothing ResourceBusy "openFile"
+ "file is locked" Nothing)
+ mkFileHandle fd filepath ha_type binary
+
+
+foreign import "lockFile" unsafe
+ lockFile :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "unlockFile" unsafe
+ unlockFile :: CInt -> IO CInt
+
+mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
+mkFileHandle fd filepath ha_type binary = do
+ (buf, bmode) <- getBuffer fd (initBufferState ha_type)
+ spares <- newIORef BufferListNil
+ newFileHandle handleFinalizer
+ (Handle__ { haFD = fd,
+ haType = ha_type,
+ haIsBin = binary,
+ haBufferMode = bmode,
+ haFilePath = filepath,
+ haBuffer = buf,
+ haBuffers = spares
+ })
+
+mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
+mkDuplexHandle fd filepath binary = do
+ (w_buf, w_bmode) <- getBuffer fd WriteBuffer
+ w_spares <- newIORef BufferListNil
+ let w_handle_ =
+ Handle__ { haFD = fd,
+ haType = WriteHandle,
+ haIsBin = binary,
+ haBufferMode = w_bmode,
+ haFilePath = filepath,
+ haBuffer = w_buf,
+ haBuffers = w_spares
+ }
+ write_side <- newMVar w_handle_
+
+ (r_buf, r_bmode) <- getBuffer fd ReadBuffer
+ r_spares <- newIORef BufferListNil
+ let r_handle_ =
+ Handle__ { haFD = fd,
+ haType = ReadSideHandle write_side,
+ haIsBin = binary,
+ haBufferMode = r_bmode,
+ haFilePath = filepath,
+ haBuffer = r_buf,
+ haBuffers = r_spares
+ }
+ read_side <- newMVar r_handle_
+
+ addMVarFinalizer write_side (handleFinalizer write_side)
+ return (DuplexHandle read_side write_side)
+
+
+initBufferState ReadHandle = ReadBuffer
+initBufferState _ = WriteBuffer
+
+-- ---------------------------------------------------------------------------
+-- Closing a handle
+
+-- Computation `hClose hdl' makes handle `hdl' closed. Before the
+-- computation finishes, any items buffered for output and not already
+-- sent to the operating system are flushed as for `hFlush'.
+
+-- For a duplex handle, we close&flush the write side, and just close
+-- the read side.
+
+hClose :: Handle -> IO ()
+hClose h@(FileHandle m) = hClose' h m
+hClose h@(DuplexHandle r w) = do
+ hClose' h w
+ withHandle__' "hClose" h r $ \ handle_ -> do
+ return handle_{ haFD = -1,
+ haType = ClosedHandle
+ }
+
+hClose' h m =
+ withHandle__' "hClose" h m $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> return handle_
+ _ -> do
+ let fd = fromIntegral (haFD handle_)
+ flushWriteBufferOnly handle_
+ throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
+
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile fd
+
+ -- 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 the size of a file
+
+-- For a handle `hdl' which attached to a physical file, `hFileSize
+-- hdl' returns the size of `hdl' in terms of the number of items
+-- which can be read from `hdl'.
+
+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)
+
+-- ---------------------------------------------------------------------------
+-- 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 throw e)
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
+-- Looking ahead
+
+-- hLookahead returns the next character from the handle without
+-- removing it from the input buffer, blocking until a character is
+-- available.
+
+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 is_line 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 mode is LineBuffering, line-buffering should be enabled if possible.
+--
+-- * If mode is `BlockBuffering size', then block-buffering
+-- should be enabled if possible. The size of the buffer is n items
+-- if size is `Just n' and is otherwise implementation-dependent.
+--
+-- * If mode is NoBuffering, then buffering is disabled if possible.
+
+-- If the buffer mode is changed from BlockBuffering or
+-- LineBuffering to NoBuffering, then any items in the output
+-- buffer are written to the device, and any items in the input buffer
+-- are discarded. The default buffering mode when a handle is opened
+-- is implementation-dependent and may depend on the object which is
+-- attached to that handle.
+
+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
+ NoBuffering -> setCooked (haFD handle_) False
+ _ -> 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.
+
+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_) 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
+
+ -- 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 an abstract position. Computation `hSetPosn p' sets the
+-- position of `hdl' to a previously obtained position `p'.
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(_WIN32)
+ -- 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 = fromIntegral (haFD handle_)
+ posn <- fromIntegral `liftM`
+ throwErrnoIfMinus1Retry "hGetPosn"
+ (c_lseek fd 0 (#const 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 (HandlePosn handle real_posn)
+
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
+
+-- ---------------------------------------------------------------------------
+-- hSeek
+
+{-
+The action `hSeek hdl mode i' sets the position of handle
+`hdl' depending on `mode'. If `mode' is
+
+ * 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.
+
+Some handles may not be seekable (see `hIsSeekable'), or only
+support a subset of the possible positioning operations (e.g. 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.
+
+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.
+-}
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+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 (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+
+ whence :: CInt
+ whence = case mode of
+ AbsoluteSeek -> (#const SEEK_SET)
+ RelativeSeek -> (#const SEEK_CUR)
+ SeekFromEnd -> (#const SEEK_END)
+
+ if bufferIsWritable buf
+ then do new_buf <- flushWriteBuffer fd 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
+
+-- -----------------------------------------------------------------------------
+-- 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 False
+hIsWritable handle =
+ withHandle_ "hIsWritable" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ htype -> return (isWritableHandleType htype)
+
+-- Querying how a handle buffers its data:
+
+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 && haIsBin handle_)
+
+-- -----------------------------------------------------------------------------
+-- Changing echo status
+
+-- Non-standard GHC extension is to allow the echoing status
+-- of a handles connected to terminals to be reconfigured:
+
+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
+
+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_)
+
+hIsTerminalDevice :: Handle -> IO Bool
+hIsTerminalDevice handle = do
+ withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ _ -> fdIsTTY (haFD handle_)
+
+-- -----------------------------------------------------------------------------
+-- hSetBinaryMode
+
+#ifdef _WIN32
+hSetBinaryMode handle bin =
+ withHandle "hSetBinaryMode" handle $ \ handle_ ->
+ do let flg | bin = (#const O_BINARY)
+ | otherwise = (#const O_TEXT)
+ throwErrnoIfMinus1_ "hSetBinaryMode"
+ (setmode (fromIntegral (haFD handle_)) flg)
+ return (handle_{haIsBin=bin}, ())
+
+foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
+#else
+hSetBinaryMode handle bin =
+ withHandle "hSetBinaryMode" handle $ \ handle_ ->
+ return (handle_{haIsBin=bin}, ())
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous
+
+-- These three functions are meant to get things out of an IOError.
+
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
+ioeGetHandle :: IOError -> Maybe Handle
+
+ioeGetHandle (IOException (IOError h _ _ _ _)) = h
+ioeGetHandle (UserError _) = Nothing
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
+ioeGetErrorString (UserError str) = str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+
+ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
+ioeGetFileName (UserError _) = Nothing
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+
+-- ---------------------------------------------------------------------------
+-- debugging
+
+#ifdef DEBUG_DUMP
+puts :: String -> IO ()
+puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
+ return ()
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#undef DEBUG_DUMP
+
+-- -----------------------------------------------------------------------------
+-- $Id: IO.hsc,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1992-2001
+--
+-- Module GHC.IO
+
+-- This module defines all basic IO operations.
+-- These are needed for the IO operations exported by Prelude,
+-- but as it happens they also do everything required by library
+-- module IO.
+
+module GHC.IO where
+
+#include "HsCore.h"
+#include "GHC/Handle_hsc.h"
+
+import Foreign
+import Foreign.C
+
+import Data.Maybe
+import Control.Monad
+
+import GHC.ByteArr
+import GHC.Enum
+import GHC.Base
+import GHC.Posix
+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, throw )
+import GHC.Conc
+
+-- ---------------------------------------------------------------------------
+-- Simple input operations
+
+-- Computation "hReady hdl" indicates whether at least
+-- one item is available for input from handle "hdl".
+
+-- 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.
+
+hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput h msecs = do
+ wantReadableHandle "hReady" h $ \ handle_ -> do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+
+ if not (bufferEmpty buf)
+ then return True
+ else do
+
+ r <- throwErrnoIfMinus1Retry "hReady"
+ (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
+ return (r /= 0)
+
+foreign import "inputReady"
+ inputReady :: CInt -> CInt -> IO CInt
+
+-- ---------------------------------------------------------------------------
+-- hGetChar
+
+-- hGetChar reads the next character from a handle,
+-- blocking until a character is available.
+
+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 buf
+ hGetcBuffered fd ref new_buf
+ BlockBuffering _ -> do
+ new_buf <- fillReadBuffer fd False buf
+ hGetcBuffered fd ref new_buf
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ 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
+
+-- If EOF is reached before EOL is encountered, ignore the EOF and
+-- return the partial line. Next attempt at calling hGetLine on the
+-- handle will yield an EOF IO exception though.
+
+-- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
+-- the duration.
+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_ = do
+ let ref = haBuffer handle_
+ buf <- readIORef ref
+ hGetLineBufferedLoop handle_ ref buf []
+
+
+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
+ 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
+ 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 -> let str = concat (reverse (xs:xss)) in
+ if not (null str)
+ then return str
+ else ioe_EOF
+ Just new_buf ->
+ hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
+
+
+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 returns the list of characters corresponding to the
+-- unread portion of the channel or file managed by the handle, which
+-- is made semi-closed.
+
+-- hGetContents on a DuplexHandle only affects the read side: you can
+-- carry on writing to it afterwards.
+
+hGetContents :: Handle -> IO String
+hGetContents handle@(DuplexHandle r w)
+ = withHandle' "hGetContents" handle r (hGetContents' handle)
+hGetContents handle@(FileHandle m)
+ = withHandle' "hGetContents" handle m (hGetContents' handle)
+
+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 ""
+ 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 lazyReadBuffered h fd ref buf
+ else do
+
+ case haBufferMode handle_ of
+ NoBuffering -> do
+ -- make use of the minimal buffer we already have
+ let raw = bufBuf buf
+ fd = haFD handle_
+ r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ (read_off (fromIntegral fd) raw 0 1)
+ (threadWaitRead fd)
+ if r == 0
+ then return ""
+ else do (c,_) <- readCharFromBuffer raw 0
+ rest <- lazyRead h
+ return (c : rest)
+
+ LineBuffering -> lazyReadBuffered h fd ref buf
+ BlockBuffering _ -> lazyReadBuffered h 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 fd ref buf = do
+ maybe_new_buf <-
+ if bufferEmpty buf
+ then maybeFillReadBuffer fd True buf
+ else return (Just buf)
+ case maybe_new_buf of
+ Nothing -> return ""
+ Just buf -> do
+ more <- lazyRead h
+ writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
+
+
+maybeFillReadBuffer fd is_line buf
+ = catch
+ (do buf <- fillReadBuffer fd is_line buf
+ return (Just buf)
+ )
+ (\e -> if isEOFError e
+ then return Nothing
+ else throw e)
+
+
+unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
+unpackAcc buf r 0 acc = return ""
+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
+
+-- `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'.
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar handle c =
+ c `seq` do -- must evaluate c before grabbing the handle lock
+ wantWritableHandle "hPutChar" handle $ \ handle_ -> do
+ let fd = haFD handle_
+ case haBufferMode handle_ of
+ LineBuffering -> hPutcBuffered handle_ True c
+ BlockBuffering _ -> hPutcBuffered handle_ False c
+ NoBuffering ->
+ withObject (castCharToCChar c) $ \buf ->
+ throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
+ (c_write (fromIntegral fd) buf 1)
+ (threadWaitWrite fd)
+
+
+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_) 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
+
+-- `hPutStr hdl s' writes the string `s' to the file or
+-- hannel managed by `hdl', buffering the output if needs be.
+
+-- 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.
+
+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
+ 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
+
+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 -- flush the handle afterward?
+ -> Bool -- release the buffer?
+ -> IO Buffer
+
+commitBuffer hdl raw sz count flush release = do
+ wantWritableHandle "commitAndReleaseBuffer" hdl $
+ \ 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 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 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 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
+ if release && bufSize buf_ret == size
+ then do
+ spare_bufs <- readIORef spare_buf_ref
+ writeIORef spare_buf_ref
+ (BufferListCons (bufBuf buf_ret) spare_bufs)
+ return buf_ret
+ else
+ return buf_ret
+
+-- ---------------------------------------------------------------------------
+-- Reading/writing sequences of bytes.
+
+{-
+Semantics of hGetBuf:
+
+ - hGetBuf reads data into the buffer until either
+
+ (a) EOF is reached
+ (b) the buffer is full
+
+ It returns the amount of data actually read. This may
+ be zero in case (a). hGetBuf never raises
+ an EOF exception, it always returns zero instead.
+
+ If the handle is a pipe or socket, and the writing end
+ is closed, hGetBuf will behave as for condition (a).
+
+Semantics of hPutBuf:
+
+ - hPutBuf writes data from the buffer to the handle
+ until the buffer is empty. It returns ().
+
+ If the handle is a pipe or socket, and the reading end is
+ closed, hPutBuf will raise a ResourceVanished exception.
+ (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
+
+hPutBuf :: Handle -- handle to write to
+ -> Ptr a -- address of buffer
+ -> Int -- number of bytes of data in buffer
+ -> IO ()
+hPutBuf handle ptr count
+ | count <= 0 = illegalBufferSize handle "hPutBuf" count
+ | otherwise =
+ wantWritableHandle "hPutBuf" handle $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> 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_ptr old_raw w ptr (fromIntegral count)
+ writeIORef ref old_buf{ bufWPtr = w + count }
+ return ()
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer fd old_buf
+ writeIORef ref flushed_buf
+ -- ToDo: should just memcpy instead of writing if possible
+ writeChunk fd ptr count
+
+writeChunk :: FD -> Ptr a -> Int -> IO ()
+writeChunk fd ptr bytes = loop 0 bytes
+ where
+ loop :: Int -> Int -> IO ()
+ loop _ bytes | bytes <= 0 = return ()
+ loop off bytes = do
+ r <- fromIntegral `liftM`
+ throwErrnoIfMinus1RetryMayBlock "writeChunk"
+ (c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
+ (threadWaitWrite fd)
+ -- write can't return 0
+ loop (off + r) (bytes - r)
+
+-- ---------------------------------------------------------------------------
+-- hGetBuf
+
+hGetBuf :: Handle -> Ptr a -> Int -> IO Int
+hGetBuf handle ptr count
+ | count <= 0 = illegalBufferSize handle "hGetBuf" count
+ | otherwise =
+ wantReadableHandle "hGetBuf" handle $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+ buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
+ if bufferEmpty buf
+ then readChunk fd ptr count
+ else do
+ let avail = w - r
+ copied <- if (count >= avail)
+ then do
+ memcpy_ptr_baoff ptr raw r (fromIntegral avail)
+ writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
+ return avail
+ else do
+ memcpy_ptr_baoff ptr raw r (fromIntegral count)
+ writeIORef ref buf{ bufRPtr = r + count }
+ return count
+
+ let remaining = count - copied
+ if remaining > 0
+ then do rest <- readChunk fd (ptr `plusPtr` copied) remaining
+ return (rest + count)
+ else return count
+
+readChunk :: FD -> Ptr a -> Int -> IO Int
+readChunk fd 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`
+ throwErrnoIfMinus1RetryMayBlock "readChunk"
+ (c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes))
+ (threadWaitRead fd)
+ if r == 0
+ then return off
+ else loop (off + r) (bytes - r)
+
+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
+ chunk <- mallocBytes sz_i
+ r <- hGetBuf handle chunk sz_i
+ hClose handle
+ return (chunk, r)
+
+-- ---------------------------------------------------------------------------
+-- hGetBufBA
+
+hGetBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int
+hGetBufBA handle (MutableByteArray _ _ ptr) count
+ | count <= 0 = illegalBufferSize handle "hGetBuf" count
+ | otherwise =
+ wantReadableHandle "hGetBuf" handle $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> do
+ buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r } <- readIORef ref
+ if bufferEmpty buf
+ then readChunkBA fd ptr 0 count
+ else do
+ let avail = w - r
+ copied <- if (count >= avail)
+ then do
+ memcpy_ba_baoff ptr raw r (fromIntegral avail)
+ writeIORef ref buf{ bufWPtr=0, bufRPtr=0 }
+ return avail
+ else do
+ memcpy_ba_baoff ptr raw r (fromIntegral count)
+ writeIORef ref buf{ bufRPtr = r + count }
+ return count
+
+ let remaining = count - copied
+ if remaining > 0
+ then do rest <- readChunkBA fd ptr copied remaining
+ return (rest + count)
+ else return count
+
+readChunkBA :: FD -> RawBuffer -> Int -> Int -> IO Int
+readChunkBA fd 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 <- fromIntegral `liftM`
+ throwErrnoIfMinus1RetryMayBlock "readChunk"
+ (readBA (fromIntegral fd) ptr
+ (fromIntegral off) (fromIntegral bytes))
+ (threadWaitRead fd)
+ if r == 0
+ then return (off - init_off)
+ else loop (off + r) (bytes - r)
+
+foreign import "read_ba_wrap" unsafe
+ readBA :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+#def inline \
+int read_ba_wrap(int fd, void *ptr, HsInt off, int size) \
+{ return read(fd, ptr + off, size); }
+
+-- -----------------------------------------------------------------------------
+-- hPutBufBA
+
+hPutBufBA
+ :: Handle -- handle to write to
+ -> MutableByteArray RealWorld a -- buffer
+ -> Int -- number of bytes of data in buffer
+ -> IO ()
+
+hPutBufBA handle (MutableByteArray _ _ raw) count
+ | count <= 0 = illegalBufferSize handle "hPutBufBA" count
+ | otherwise = do
+ wantWritableHandle "hPutBufBA" handle $
+ \ handle_@Handle__{ haFD=fd, haBuffer=ref } -> 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 w raw (fromIntegral count)
+ writeIORef ref old_buf{ bufWPtr = w + count }
+ return ()
+
+ -- else, we have to flush
+ else do flushed_buf <- flushWriteBuffer fd old_buf
+ writeIORef ref flushed_buf
+ let this_buf =
+ Buffer{ bufBuf=raw, bufState=WriteBuffer,
+ bufRPtr=0, bufWPtr=count, bufSize=count }
+ flushWriteBuffer fd this_buf
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- memcpy wrappers
+
+foreign import "memcpy_wrap_src_off" unsafe
+ memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ())
+foreign import "memcpy_wrap_src_off" unsafe
+ memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ())
+foreign import "memcpy_wrap_dst_off" unsafe
+ memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
+foreign import "memcpy_wrap_dst_off" unsafe
+ memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ())
+
+#def inline \
+void *memcpy_wrap_dst_off(char *dst, int dst_off, char *src, size_t sz) \
+{ return memcpy(dst+dst_off, src, sz); }
+
+#def inline \
+void *memcpy_wrap_src_off(char *dst, char *src, int src_off, size_t sz) \
+{ return memcpy(dst, src+src_off, sz); }
+
+-----------------------------------------------------------------------------
+-- 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
+% ------------------------------------------------------------------------------
+% $Id: IOBase.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2001
+%
+
+% Definitions for the @IO@ monad and its friends. Everything is exported
+% concretely; the @IO@ module itself exports abstractly.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+#include "config.h"
+
+module GHC.IOBase where
+
+import GHC.ST
+import GHC.STRef
+import GHC.Arr
+import GHC.Base
+import GHC.Num -- To get fromInteger etc, needed because of -fno-implicit-prelude
+import GHC.Maybe ( Maybe(..) )
+import GHC.Show
+import GHC.List
+import GHC.Read
+import GHC.Dynamic
+
+-- ---------------------------------------------------------------------------
+-- 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
+-}
+
+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
+ )
+
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
+
+-- ---------------------------------------------------------------------------
+-- Coercions between IO and ST
+
+--stToIO :: (forall s. ST s a) -> IO a
+stToIO :: ST RealWorld a -> IO a
+stToIO (ST m) = IO m
+
+ioToST :: IO a -> ST RealWorld a
+ioToST (IO m) = (ST m)
+
+-- ---------------------------------------------------------------------------
+-- Unsafe IO operations
+
+{-# NOINLINE unsafePerformIO #-}
+unsafePerformIO :: IO a -> a
+unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
+
+{-# NOINLINE unsafeInterleaveIO #-}
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO (IO m)
+ = IO ( \ s -> let
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
+
+-- ---------------------------------------------------------------------------
+-- Handle type
+
+data MVar a = MVar (MVar# RealWorld a)
+
+-- 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.
+
+data Handle
+ = FileHandle -- A normal handle to a file
+ !(MVar Handle__)
+
+ | DuplexHandle -- A handle to a read/write stream
+ !(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 = Int -- XXX ToDo: should be CInt
+
+data Handle__
+ = Handle__ {
+ haFD :: !FD,
+ haType :: HandleType,
+ haIsBin :: Bool,
+ haBufferMode :: BufferMode,
+ haFilePath :: FilePath,
+ haBuffer :: !(IORef Buffer),
+ haBuffers :: !(IORef BufferList)
+ }
+
+-- ---------------------------------------------------------------------------
+-- 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
+ | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
+
+isReadableHandleType ReadHandle = True
+isReadableHandleType ReadWriteHandle = True
+isReadableHandleType (ReadSideHandle _) = True
+isReadableHandleType _ = False
+
+isWritableHandleType AppendHandle = True
+isWritableHandleType WriteHandle = True
+isWritableHandleType ReadWriteHandle = True
+isWritableHandleType _ = False
+
+-- File names are specified using @FilePath@, a OS-dependent
+-- string that (hopefully, I guess) maps to an accessible file/object.
+
+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 from the internal
+-- buffer according to the buffer mode:
+--
+-- * line-buffering the entire output buffer is written
+-- out whenever a newline is output, the output buffer overflows,
+-- a flush is issued, or the handle is closed.
+--
+-- * block-buffering the entire output buffer is written out whenever
+-- it overflows, a flush is issued, or the handle
+-- is closed.
+--
+-- * no-buffering output is written immediately, and never stored
+-- in the output buffer.
+--
+-- The output buffer is emptied as soon as it has been written out.
+
+-- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+
+-- * line-buffering when the input buffer for the handle is not empty,
+-- the next item is obtained from the buffer;
+-- otherwise, when the input 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.
+--
+-- * block-buffering when the input buffer for the handle becomes empty,
+-- the next block of data is read into this buffer.
+--
+-- * no-buffering the next input item is read and returned.
+
+-- For most implementations, physical files will normally be block-buffered
+-- and terminals will normally be line-buffered. (the IO interface provides
+-- operations for changing the default buffering of a handle tho.)
+
+data BufferMode
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+ deriving (Eq, Ord, Read, Show)
+
+-- ---------------------------------------------------------------------------
+-- IORefs
+
+newtype IORef a = IORef (STRef RealWorld a) deriving Eq
+
+newIORef :: a -> IO (IORef a)
+newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
+
+readIORef :: IORef a -> IO a
+readIORef (IORef var) = stToIO (readSTRef var)
+
+writeIORef :: IORef a -> a -> IO ()
+writeIORef (IORef var) v = stToIO (writeSTRef var v)
+
+-- ---------------------------------------------------------------------------
+-- 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"
+ ReadSideHandle _ -> showString "read-writable (duplex)"
+
+instance Show Handle where
+ showsPrec p (FileHandle h) = showHandle p h
+ showsPrec p (DuplexHandle h _) = showHandle p h
+
+showHandle p h =
+ let
+ -- (Big) SIGH: unfolded defn of takeMVar to avoid
+ -- an (oh-so) unfortunate module loop with GHC.Conc.
+ hdl_ = unsafePerformIO (IO $ \ s# ->
+ case h of { MVar h# ->
+ case takeMVar# h# s# of { (# s2# , r #) ->
+ case putMVar# h# r s2# of { s3# ->
+ (# s3#, r #) }}})
+ in
+ showChar '{' .
+ showHdl (haType hdl_)
+ (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
+ showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
+ showString "binary=" . showsPrec p (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 -> showsPrec p 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 (showsPrec p n)
+ BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
+ where
+ def :: Int
+ def = bufSize buf
+
+-- ------------------------------------------------------------------------
+-- Exception datatype and operations
+
+data Exception
+ = IOException IOException -- IO exceptions
+ | ArithException ArithException -- Arithmetic exceptions
+ | ArrayException ArrayException -- Array-related exceptions
+ | ErrorCall String -- Calls to 'error'
+ | ExitException ExitCode -- Call to System.exitWith
+ | NoMethodError String -- A non-existent method was invoked
+ | PatternMatchFail String -- A pattern match / guard failure
+ | RecSelError String -- Selecting a non-existent field
+ | RecConError String -- Field missing in record construction
+ | RecUpdError String -- Record doesn't contain updated field
+ | AssertionFailed String -- Assertions
+ | DynException Dynamic -- Dynamic exceptions
+ | AsyncException AsyncException -- Externally generated errors
+ | BlockedOnDeadMVar -- Blocking on a dead MVar
+ | NonTermination
+ | UserError String
+
+data ArithException
+ = Overflow
+ | Underflow
+ | LossOfPrecision
+ | DivideByZero
+ | Denormal
+ deriving (Eq, Ord)
+
+data AsyncException
+ = StackOverflow
+ | HeapOverflow
+ | ThreadKilled
+ deriving (Eq, Ord)
+
+data ArrayException
+ = IndexOutOfBounds String -- out-of-range array access
+ | UndefinedElement String -- evaluating an undefined element
+ 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 "unknown exception"
+ showsPrec _ (AsyncException e) = shows e
+ showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
+ showsPrec _ (NonTermination) = showString "<<loop>>"
+ showsPrec _ (UserError err) = showString err
+
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
+
+-- The `ExitCode' type defines the exit codes that a program
+-- can return. `ExitSuccess' indicates successful termination;
+-- and `ExitFailure code' indicates program failure
+-- with value `code'. The exact interpretation of `code'
+-- is operating-system dependent. In particular, some values of
+-- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
+
+-- We need it here because it is used in ExitException in the
+-- Exception datatype (above).
+
+data ExitCode = ExitSuccess | ExitFailure Int
+ deriving (Eq, Ord, Read, Show)
+
+-- --------------------------------------------------------------------------
+-- Primitive throw
+
+throw :: Exception -> a
+throw exception = raise# exception
+
+ioError :: Exception -> IO a
+ioError err = IO $ \s -> throw err s
+
+ioException :: IOException -> IO a
+ioException err = IO $ \s -> throw (IOException err) s
+
+-- ---------------------------------------------------------------------------
+-- IOError type
+
+-- A value @IOError@ encode errors occurred in the @IO@ monad.
+-- An @IOError@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
+
+type IOError = Exception
+
+data IOException
+ = IOError
+ (Maybe Handle) -- the handle used by the action flagging the
+ -- the error.
+ IOErrorType -- what it was.
+ String -- location.
+ String -- error type specific information.
+ (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
+
+data IOErrorType
+ = AlreadyExists | HardwareFault
+ | IllegalOperation | InappropriateType
+ | Interrupted | InvalidArgument
+ | NoSuchThing | OtherError
+ | PermissionDenied | ProtocolError
+ | ResourceBusy | ResourceExhausted
+ | ResourceVanished | SystemError
+ | TimeExpired | UnsatisfiedConstraints
+ | UnsupportedOperation
+ | EOF
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ | ComError Int -- HRESULT
+#endif
+ deriving (Eq)
+
+instance Show IOErrorType where
+ showsPrec _ e =
+ showString $
+ case e of
+ AlreadyExists -> "already exists"
+ HardwareFault -> "hardware fault"
+ IllegalOperation -> "illegal operation"
+ InappropriateType -> "inappropriate type"
+ Interrupted -> "interrupted"
+ InvalidArgument -> "invalid argument"
+ NoSuchThing -> "does not exist"
+ OtherError -> "failed"
+ PermissionDenied -> "permission denied"
+ ProtocolError -> "protocol error"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ ResourceVanished -> "resource vanished"
+ SystemError -> "system error"
+ TimeExpired -> "timeout"
+ UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
+ UnsupportedOperation -> "unsupported operation"
+ EOF -> "end of file"
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
+ ComError _ -> "COM error"
+#endif
+
+
+
+userError :: String -> IOError
+userError str = UserError str
+
+-- ---------------------------------------------------------------------------
+-- Predicates on IOError
+
+isAlreadyExistsError :: IOError -> Bool
+isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
+isAlreadyExistsError _ = False
+
+isAlreadyInUseError :: IOError -> Bool
+isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
+isAlreadyInUseError _ = False
+
+isFullError :: IOError -> Bool
+isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
+isFullError _ = False
+
+isEOFError :: IOError -> Bool
+isEOFError (IOException (IOError _ EOF _ _ _)) = True
+isEOFError _ = False
+
+isIllegalOperation :: IOError -> Bool
+isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
+isIllegalOperation _ = False
+
+isPermissionError :: IOError -> Bool
+isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
+isPermissionError _ = False
+
+isDoesNotExistError :: IOError -> Bool
+isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
+isDoesNotExistError _ = False
+
+isUserError :: IOError -> Bool
+isUserError (UserError _) = True
+isUserError _ = False
+
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors
+
+instance Show IOException where
+ showsPrec p (IOError hdl iot loc s fn) =
+ showsPrec p iot .
+ (case loc of
+ "" -> id
+ _ -> showString "\nAction: " . showString loc) .
+ (case hdl of
+ Nothing -> id
+ Just h -> showString "\nHandle: " . showsPrec p h) .
+ (case s of
+ "" -> id
+ _ -> showString "\nReason: " . showString s) .
+ (case fn of
+ Nothing -> id
+ Just name -> showString "\nFile: " . showString name)
+\end{code}
--- /dev/null
+%
+% (c) The University of Glasgow, 1997-2001
+%
+\section[GHC.Int]{Module @GHC.Int@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#include "MachDeps.h"
+
+module GHC.Int (
+ Int8(..), Int16(..), Int32(..), Int64(..))
+ where
+
+import Data.Bits
+
+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)
+
+instance CCallable Int8
+instance CReturnable Int8
+
+instance Show Int8 where
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+
+instance Num Int8 where
+ (I8# x#) + (I8# y#) = I8# (intToInt8# (x# +# y#))
+ (I8# x#) - (I8# y#) = I8# (intToInt8# (x# -# y#))
+ (I8# x#) * (I8# y#) = I8# (intToInt8# (x# *# y#))
+ negate (I8# x#) = I8# (intToInt8# (negateInt# x#))
+ abs x | x >= 0 = x
+ | otherwise = negate x
+ signum x | x > 0 = 1
+ signum 0 = 0
+ signum _ = -1
+ fromInteger (S# i#) = I8# (intToInt8# i#)
+ fromInteger (J# s# d#) = I8# (intToInt8# (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 = I8# (intToInt8# (x# `quotInt#` y#))
+ | otherwise = divZeroError "quot{Int8}" x
+ rem x@(I8# x#) y@(I8# y#)
+ | y /= 0 = I8# (intToInt8# (x# `remInt#` y#))
+ | otherwise = divZeroError "rem{Int8}" x
+ div x@(I8# x#) y@(I8# y#)
+ | y /= 0 = I8# (intToInt8# (x# `divInt#` y#))
+ | otherwise = divZeroError "div{Int8}" x
+ mod x@(I8# x#) y@(I8# y#)
+ | y /= 0 = I8# (intToInt8# (x# `modInt#` y#))
+ | otherwise = divZeroError "mod{Int8}" x
+ quotRem x@(I8# x#) y@(I8# y#)
+ | y /= 0 = (I8# (intToInt8# (x# `quotInt#` y#)),
+ I8# (intToInt8# (x# `remInt#` y#)))
+ | otherwise = divZeroError "quotRem{Int8}" x
+ divMod x@(I8# x#) y@(I8# y#)
+ | y /= 0 = (I8# (intToInt8# (x# `divInt#` y#)),
+ I8# (intToInt8# (x# `modInt#` y#)))
+ | otherwise = divZeroError "divMod{Int8}" x
+ toInteger (I8# x#) = S# x#
+
+instance Bounded Int8 where
+ minBound = -0x80
+ maxBound = 0x7F
+
+instance Ix Int8 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Int8"
+ 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
+ (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# (intToInt8# (x# `iShiftL#` i#))
+ | otherwise = I8# (x# `iShiftRA#` negateInt# i#)
+ (I8# x#) `rotate` (I# i#) =
+ I8# (intToInt8# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (8# -# i'#)))))
+ where
+ x'# = wordToWord8# (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# (intToInt8# 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)
+
+instance CCallable Int16
+instance CReturnable Int16
+
+instance Show Int16 where
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+
+instance Num Int16 where
+ (I16# x#) + (I16# y#) = I16# (intToInt16# (x# +# y#))
+ (I16# x#) - (I16# y#) = I16# (intToInt16# (x# -# y#))
+ (I16# x#) * (I16# y#) = I16# (intToInt16# (x# *# y#))
+ negate (I16# x#) = I16# (intToInt16# (negateInt# x#))
+ abs x | x >= 0 = x
+ | otherwise = negate x
+ signum x | x > 0 = 1
+ signum 0 = 0
+ signum _ = -1
+ fromInteger (S# i#) = I16# (intToInt16# i#)
+ fromInteger (J# s# d#) = I16# (intToInt16# (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 = I16# (intToInt16# (x# `quotInt#` y#))
+ | otherwise = divZeroError "quot{Int16}" x
+ rem x@(I16# x#) y@(I16# y#)
+ | y /= 0 = I16# (intToInt16# (x# `remInt#` y#))
+ | otherwise = divZeroError "rem{Int16}" x
+ div x@(I16# x#) y@(I16# y#)
+ | y /= 0 = I16# (intToInt16# (x# `divInt#` y#))
+ | otherwise = divZeroError "div{Int16}" x
+ mod x@(I16# x#) y@(I16# y#)
+ | y /= 0 = I16# (intToInt16# (x# `modInt#` y#))
+ | otherwise = divZeroError "mod{Int16}" x
+ quotRem x@(I16# x#) y@(I16# y#)
+ | y /= 0 = (I16# (intToInt16# (x# `quotInt#` y#)),
+ I16# (intToInt16# (x# `remInt#` y#)))
+ | otherwise = divZeroError "quotRem{Int16}" x
+ divMod x@(I16# x#) y@(I16# y#)
+ | y /= 0 = (I16# (intToInt16# (x# `divInt#` y#)),
+ I16# (intToInt16# (x# `modInt#` y#)))
+ | otherwise = divZeroError "divMod{Int16}" x
+ toInteger (I16# x#) = S# x#
+
+instance Bounded Int16 where
+ minBound = -0x8000
+ maxBound = 0x7FFF
+
+instance Ix Int16 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Int16"
+ 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
+ (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# (intToInt16# (x# `iShiftL#` i#))
+ | otherwise = I16# (x# `iShiftRA#` negateInt# i#)
+ (I16# x#) `rotate` (I# i#) =
+ I16# (intToInt16# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (16# -# i'#)))))
+ where
+ x'# = wordToWord16# (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# (intToInt16# x#)
+"fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#)
+ #-}
+
+------------------------------------------------------------------------
+-- type Int32
+------------------------------------------------------------------------
+
+-- Int32 is represented in the same way as Int.
+#if WORD_SIZE_IN_BYTES == 8
+-- Operations may assume and must ensure that it holds only values
+-- from its logical range.
+#endif
+
+data Int32 = I32# Int# deriving (Eq, Ord)
+
+instance CCallable Int32
+instance CReturnable Int32
+
+instance Show Int32 where
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+
+instance Num Int32 where
+ (I32# x#) + (I32# y#) = I32# (intToInt32# (x# +# y#))
+ (I32# x#) - (I32# y#) = I32# (intToInt32# (x# -# y#))
+ (I32# x#) * (I32# y#) = I32# (intToInt32# (x# *# y#))
+ negate (I32# x#) = I32# (intToInt32# (negateInt# 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# (intToInt32# (integer2Int# s# d#))
+
+instance Real Int32 where
+ toRational x = toInteger x % 1
+
+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_BYTES == 4
+ 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 = I32# (intToInt32# (x# `quotInt#` y#))
+ | otherwise = divZeroError "quot{Int32}" x
+ rem x@(I32# x#) y@(I32# y#)
+ | y /= 0 = I32# (intToInt32# (x# `remInt#` y#))
+ | otherwise = divZeroError "rem{Int32}" x
+ div x@(I32# x#) y@(I32# y#)
+ | y /= 0 = I32# (intToInt32# (x# `divInt#` y#))
+ | otherwise = divZeroError "div{Int32}" x
+ mod x@(I32# x#) y@(I32# y#)
+ | y /= 0 = I32# (intToInt32# (x# `modInt#` y#))
+ | otherwise = divZeroError "mod{Int32}" x
+ quotRem x@(I32# x#) y@(I32# y#)
+ | y /= 0 = (I32# (intToInt32# (x# `quotInt#` y#)),
+ I32# (intToInt32# (x# `remInt#` y#)))
+ | otherwise = divZeroError "quotRem{Int32}" x
+ divMod x@(I32# x#) y@(I32# y#)
+ | y /= 0 = (I32# (intToInt32# (x# `divInt#` y#)),
+ I32# (intToInt32# (x# `modInt#` y#)))
+ | otherwise = divZeroError "divMod{Int32}" x
+ toInteger (I32# x#) = S# x#
+
+instance Bounded Int32 where
+ minBound = -0x80000000
+ maxBound = 0x7FFFFFFF
+
+instance Ix Int32 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Int32"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Read Int32 where
+ readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
+
+instance Bits Int32 where
+ (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# (intToInt32# (x# `iShiftL#` i#))
+ | otherwise = I32# (x# `iShiftRA#` negateInt# i#)
+ (I32# x#) `rotate` (I# i#) =
+ I32# (intToInt32# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (32# -# i'#)))))
+ where
+ x'# = wordToWord32# (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# (intToInt32# x#)
+"fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#)
+ #-}
+
+------------------------------------------------------------------------
+-- type Int64
+------------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BYTES == 4
+
+data Int64 = I64# Int64#
+
+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 = I64# (x# `quotInt64#` y#)
+ | otherwise = divZeroError "quot{Int64}" x
+ rem x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `remInt64#` y#)
+ | otherwise = divZeroError "rem{Int64}" x
+ div x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `divInt64#` y#)
+ | otherwise = divZeroError "div{Int64}" x
+ mod x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `modInt64#` y#)
+ | otherwise = divZeroError "mod{Int64}" x
+ quotRem x@(I64# x#) y@(I64# y#)
+ | y /= 0 = (I64# (x# `quotInt64#` y#), I64# (x# `remInt64#` y#))
+ | otherwise = divZeroError "quotRem{Int64}" x
+ divMod x@(I64# x#) y@(I64# y#)
+ | y /= 0 = (I64# (x# `divInt64#` y#), I64# (x# `modInt64#` y#))
+ | otherwise = divZeroError "divMod{Int64}" x
+ toInteger x@(I64# x#)
+ | x >= -0x80000000 && x <= 0x7FFFFFFF
+ = 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
+ (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#) =
+ I64# (word64ToInt64# ((x'# `shiftL64#` i'#) `or64#`
+ (x'# `shiftRL64#` (64# -# i'#))))
+ where
+ x'# = int64ToWord64# x#
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
+ bitSize _ = 64
+ isSigned _ = True
+
+foreign import "stg_eqInt64" unsafe eqInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_neInt64" unsafe neInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_ltInt64" unsafe ltInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_leInt64" unsafe leInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_gtInt64" unsafe gtInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_geInt64" unsafe geInt64# :: Int64# -> Int64# -> Bool
+foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64#
+foreign import "stg_quotInt64" unsafe quotInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_remInt64" unsafe remInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64#
+foreign import "stg_int64ToInt" unsafe int64ToInt# :: Int64# -> Int#
+foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64#
+foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64#
+foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64#
+foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_not64" unsafe not64# :: Word64# -> Word64#
+foreign import "stg_iShiftL64" unsafe iShiftL64# :: Int64# -> Int# -> Int64#
+foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> Int64#
+foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
+
+{-# 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
+
+data Int64 = I64# Int# deriving (Eq, Ord)
+
+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 = I64# (x# `quotInt#` y#)
+ | otherwise = divZeroError "quot{Int64}" x
+ rem x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `remInt#` y#)
+ | otherwise = divZeroError "rem{Int64}" x
+ div x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `divInt#` y#)
+ | otherwise = divZeroError "div{Int64}" x
+ mod x@(I64# x#) y@(I64# y#)
+ | y /= 0 = I64# (x# `modInt#` y#)
+ | otherwise = divZeroError "mod{Int64}" x
+ quotRem x@(I64# x#) y@(I64# y#)
+ | y /= 0 = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))
+ | otherwise = divZeroError "quotRem{Int64}" x
+ divMod x@(I64# x#) y@(I64# y#)
+ | y /= 0 = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))
+ | otherwise = divZeroError "divMod{Int64}" x
+ 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
+ (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#) =
+ I64# (word2Int# ((x'# `shiftL#` i'#) `or#`
+ (x'# `shiftRL#` (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# (intToInt64# x#)
+"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#)
+ #-}
+
+#endif
+
+instance CCallable Int64
+instance CReturnable Int64
+
+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]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Int64"
+ inRange (m,n) i = m <= i && i <= n
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: List.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.List]{Module @GHC.List@}
+
+The List data type and its operations
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.List (
+ [] (..),
+
+ map, (++), filter, concat,
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, 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,
+ maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3,
+#ifdef USE_REPORT_PRELUDE
+
+#else
+
+ -- non-standard, but hidden when creating the Prelude
+ -- export list.
+ takeUInt_append
+
+#endif
+
+ ) where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Tup
+import GHC.Maybe
+import GHC.Base
+
+infixl 9 !!
+infix 4 `elem`, `notElem`
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{List-manipulation functions}
+%* *
+%*********************************************************
+
+\begin{code}
+-- head and tail extract the first element and remaining elements,
+-- respectively, of a list, which must be non-empty. last and init
+-- are the dual functions working from the end of a finite list,
+-- rather than the beginning.
+
+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.(Bool->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)
+ #-}
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+tail [] = errorEmptyList "tail"
+
+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
+
+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
+
+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 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 = filterList
+
+filterFB c p x r | p x = x `c` r
+ | otherwise = r
+
+{-# RULES
+"filter" forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs)
+"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
+"filterList" forall p. foldr (filterFB (:) p) [] = filterList p
+ #-}
+
+-- 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.
+
+filterList :: (a -> Bool) -> [a] -> [a]
+filterList _pred [] = []
+filterList pred (x:xs)
+ | pred x = x : filterList pred xs
+ | otherwise = filterList pred xs
+
+-- 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
+-- foldl1 is a variant that has no starting value argument, and thus must
+-- be applied to non-empty lists. 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.
+-- scanl1 is similar, again without the starting element:
+-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+-- 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
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+foldl1 _ [] = errorEmptyList "foldl1"
+
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q ls = q : (case ls of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+scanl1 _ [] = errorEmptyList "scanl1"
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 _ [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+foldr1 _ [] = errorEmptyList "foldr1"
+
+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 :: (a -> a -> a) -> [a] -> [a]
+scanr1 _ [x] = [x]
+scanr1 f (x:xs) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+scanr1 _ [] = errorEmptyList "scanr1"
+
+-- 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 = iterateList
+
+iterateFB c f x = x `c` iterateFB c f (f x)
+
+iterateList f x = x : iterateList f (f x)
+
+{-# RULES
+"iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
+"iterateFB" iterateFB (:) = iterateList
+ #-}
+
+
+-- repeat x is an infinite list, with x the value of every element.
+repeat :: a -> [a]
+repeat = repeatList
+
+repeatFB c x = xs where xs = x `c` xs
+repeatList x = xs where xs = x : xs
+
+{-# RULES
+"repeat" forall x. repeat x = build (\c _n -> repeatFB c x)
+"repeatFB" repeatFB (:) = repeatList
+ #-}
+
+-- replicate n x is a list of length n with x the value of every element
+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. dropWhile p xs
+-- returns the remaining suffix. Span p xs is equivalent to
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
+
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile _ [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+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. drop n xs returns the suffix of xs
+-- after the first n elements, or [] if n > length xs. splitAt n xs
+-- is equivalent to (take n xs, drop n xs).
+#ifdef USE_REPORT_PRELUDE
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n > 0 = x : take (minusInt n 1) xs
+take _ _ = errorNegativeIdx "take"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n > 0 = drop (minusInt n 1) xs
+drop _ _ = errorNegativeIdx "drop"
+
+
+splitAt :: Int -> [a] -> ([a],[a])
+splitAt 0 xs = ([],xs)
+splitAt _ [] = ([],[])
+splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (minusInt n 1) xs
+splitAt _ _ = errorNegativeIdx "splitAt"
+
+#else /* hack away */
+take :: Int -> [b] -> [b]
+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 = errorNegativeIdx "take"
+
+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 = errorNegativeIdx "take"
+
+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 :: Int -> [b] -> [b]
+drop (I# n#) ls
+ | n# <# 0# = errorNegativeIdx "drop"
+ | otherwise = drop# n# ls
+ where
+ drop# :: Int# -> [a] -> [a]
+ drop# 0# xs = xs
+ drop# _ xs@[] = xs
+ drop# m# (_:xs) = drop# (m# -# 1#) xs
+
+splitAt :: Int -> [b] -> ([b], [b])
+splitAt (I# n#) ls
+ | n# <# 0# = errorNegativeIdx "splitAt"
+ | 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, break :: (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)
+
+#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. or is the
+-- disjunctive dual of and.
+and, 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. Similarly, for all.
+any, 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. notElem is the negation.
+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
+
+
+-- maximum and minimum return the maximum or minimum value from a list,
+-- which must be non-empty, finite, and of an ordered type.
+{-# SPECIALISE maximum :: [Int] -> Int #-}
+{-# SPECIALISE minimum :: [Int] -> Int #-}
+maximum, minimum :: (Ord a) => [a] -> a
+maximum [] = errorEmptyList "maximum"
+maximum xs = foldl1 max xs
+
+minimum [] = errorEmptyList "minimum"
+minimum xs = foldl1 min xs
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = foldr ((++) . f) []
+
+concat :: [[a]] -> [a]
+concat = foldr (++) []
+
+{-# RULES
+ "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs)
+ #-}
+\end{code}
+
+
+\begin{code}
+-- List index (subscript) operator, 0-origin
+(!!) :: [a] -> Int -> a
+#ifdef USE_REPORT_PRELUDE
+(x:_) !! 0 = x
+(_:xs) !! n | n > 0 = xs !! (minusInt n 1)
+(_:_) !! _ = error "Prelude.(!!): negative index"
+[] !! _ = error "Prelude.(!!): index too large"
+#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.
+
+
+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.
+zip3 takes three lists and returns a list of triples. Zips for larger
+tuples are in the List module.
+
+\begin{code}
+----------------------------------------------
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipList
+
+zipFB c x y r = (x,y) `c` r
+
+
+zipList :: [a] -> [b] -> [(a,b)]
+zipList (a:as) (b:bs) = (a,b) : zipList as bs
+zipList _ _ = []
+
+{-# RULES
+"zip" forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
+"zipList" foldr2 (zipFB (:)) [] = zipList
+ #-}
+\end{code}
+
+\begin{code}
+----------------------------------------------
+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.
+-- For example, zipWith (+) is applied to two lists to produce the list
+-- of corresponding sums.
+
+
+\begin{code}
+----------------------------------------------
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith = zipWithList
+
+
+zipWithFB c f x y r = (x `f` y) `c` r
+
+zipWithList :: (a->b->c) -> [a] -> [b] -> [c]
+zipWithList f (a:as) (b:bs) = f a b : zipWithList f as bs
+zipWithList _ _ _ = []
+
+{-# RULES
+"zipWith" forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
+"zipWithList" forall f. foldr2 (zipWithFB (:) f) [] = zipWithList f
+ #-}
+\end{code}
+
+\begin{code}
+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 pair of lists.
+unzip :: [(a,b)] -> ([a],[b])
+{-# INLINE unzip #-}
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+
+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")
+
+errorNegativeIdx :: String -> a
+errorNegativeIdx fun =
+ error (prel_list_str ++ fun ++ ": negative index")
+
+prel_list_str :: String
+prel_list_str = "Prelude."
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Main.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Main]{Module @GHC.Main@}
+
+\begin{code}
+module GHC.Main( mainIO ) where
+
+import {-# SOURCE #-} qualified Main -- for type of "Main.main"
+
+import Prelude
+
+import System.IO
+import GHC.Exception
+import GHC.TopHandler
+
+mainIO :: IO () -- It must be of type (IO t) because that's what
+ -- the RTS expects. GHC doesn't check this, so
+ -- make sure this type signature stays!
+mainIO = catchException Main.main topHandler
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Maybe.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+
+\section[GHC.Maybe]{Module @GHC.Maybe@}
+
+The @Maybe@ type.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Maybe where
+
+import GHC.Base
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Maybe type}
+%* *
+%*********************************************************
+
+\begin{code}
+data Maybe a = Nothing | Just a deriving (Eq, Ord)
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n _ Nothing = n
+maybe _ f (Just x) = f x
+
+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
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Either type}
+%* *
+%*********************************************************
+
+\begin{code}
+data Either a b = Left a | Right b deriving (Eq, Ord )
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either f _ (Left x) = f x
+either _ g (Right y) = g y
+\end{code}
+
+
+
+
--- /dev/null
+---------------------------------------------------------------------------
+-- PrelNum.hi-boot
+--
+-- This hand-written interface file is the
+-- initial bootstrap version for PrelNum.hi.
+-- It's needed for the 'thin-air' Id addr2Integer, when compiling
+-- PrelBase, and other Prelude files that precede PrelNum
+---------------------------------------------------------------------------
+
+__interface "std" PrelNum 1 where
+__export PrelNum Integer addr2Integer ;
+
+1 data Integer ;
+1 addr2Integer :: PrelGHC.Addrzh -> Integer ;
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Num.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Num]{Module @GHC.Num@}
+
+The class
+
+ Num
+
+and the type
+
+ Integer
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Num where
+
+import {-# SOURCE #-} GHC.Err
+import GHC.Base
+import GHC.List
+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}
+class (Eq a, Show a) => Num a where
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: Integer -> a
+
+ x - y = x + negate y
+ negate x = 0 - x
+
+{-# 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
+\end{code}
+
+
+\begin{code}
+-- These can't go in GHC.Base with the defn of Int, because
+-- we don't have pairs defined at that time!
+
+quotRemInt :: Int -> Int -> (Int, Int)
+a@(I# _) `quotRemInt` 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}
+data Integer
+ = S# Int# -- small integers
+ | J# Int# ByteArray# -- large integers
+\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# (-2147483648#)) 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# (-2147483648#)) 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 0
+ = error "Prelude.Integral.rem{Integer}: divide by 0"
+remInteger a@(S# (-2147483648#)) 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 0
+ = error "Prelude.Integral.quot{Integer}: divide by 0"
+quotInteger a@(S# (-2147483648#)) 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# (-2147483648#)) b = gcdInteger (toBig a) b
+gcdInteger a b@(S# (-2147483648#)) = 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# (-2147483648#)) 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# (-2147483648#)) = 2147483648
+ 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) = case mulIntC# i j of { (# r, c #) ->
+ if c ==# 0# then S# r
+ 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# (-2147483648#)) = 2147483648
+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 = efdInteger x 1
+ enumFromThen x y = efdInteger x (y-x)
+ enumFromTo x lim = efdtInteger x 1 lim
+ enumFromThenTo x y lim = efdtInteger x (y-x) lim
+
+
+efdInteger = enumDeltaIntegerList
+efdtInteger = enumDeltaToIntegerList
+
+{-# RULES
+"efdInteger" forall x y. efdInteger x y = build (\c _ -> enumDeltaIntegerFB c x y)
+"efdtInteger" forall x y l.efdtInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
+"enumDeltaInteger" enumDeltaIntegerFB (:) = enumDeltaIntegerList
+"enumDeltaToInteger" enumDeltaToIntegerFB (:) [] = enumDeltaToIntegerList
+ #-}
+
+enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b
+enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d
+
+enumDeltaIntegerList :: Integer -> Integer -> [Integer]
+enumDeltaIntegerList x d = x : enumDeltaIntegerList (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
+
+enumDeltaToIntegerList 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
+ | n < 0 && p > 6 = '(' : jtos n (')' : r)
+ | otherwise = jtos n r
+ showList = showList__ (showsPrec 0)
+
+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' < 10 = case unsafeChr (ord '0' + fromInteger n') of
+ c@(C# _) -> c:cs'
+ | otherwise = case unsafeChr (ord '0' + fromInteger r) of
+ c@(C# _) -> jtos' q (c:cs')
+ where
+ (q,r) = n' `quotRemInteger` 10
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Pack.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1997-2000
+%
+
+\section[GHC.Pack]{Packing/unpacking bytes}
+
+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.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Pack
+ (
+ -- (**) - emitted by compiler.
+
+ packCString#, -- :: [Char] -> ByteArray# **
+ packString, -- :: [Char] -> ByteArray Int
+ packStringST, -- :: [Char] -> ST s (ByteArray Int)
+ packNBytesST, -- :: Int -> [Char] -> ST s (ByteArray Int)
+
+ unpackCString, -- :: Ptr a -> [Char]
+ unpackCStringST, -- :: Ptr a -> ST s [Char]
+ unpackNBytes, -- :: Ptr a -> Int -> [Char]
+ unpackNBytesST, -- :: Ptr a -> Int -> ST s [Char]
+ unpackNBytesAccST, -- :: Ptr a -> Int -> [Char] -> ST s [Char]
+ unpackNBytesAccST#,-- :: Ptr a -> Int -> [Char] -> ST s [Char]
+ unpackCString#, -- :: Addr# -> [Char] **
+ unpackNBytes#, -- :: Addr# -> Int# -> [Char] **
+ unpackNBytesST#, -- :: Addr# -> Int# -> ST s [Char]
+
+ unpackCStringBA, -- :: ByteArray Int -> [Char]
+ unpackNBytesBA, -- :: ByteArray Int -> Int -> [Char]
+ unpackCStringBA#, -- :: ByteArray# -> Int# -> [Char]
+ unpackNBytesBA#, -- :: ByteArray# -> Int# -> [Char]
+
+
+ unpackFoldrCString#, -- **
+ unpackAppendCString#, -- **
+
+ 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)
+
+ )
+ where
+
+import GHC.Base
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.List ( length )
+import GHC.ST
+import GHC.Num
+import GHC.ByteArr
+import Foreign.Ptr
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Unpacking Ptrs}
+%* *
+%*********************************************************
+
+Primitives for converting Addrs pointing to external
+sequence of bytes into a list of @Char@s:
+
+\begin{code}
+unpackCString :: Ptr a -> [Char]
+unpackCString a@(Ptr addr)
+ | a == nullPtr = []
+ | otherwise = unpackCString# addr
+
+unpackNBytes :: Ptr a -> Int -> [Char]
+unpackNBytes (Ptr addr) (I# l) = unpackNBytes# addr l
+
+unpackCStringST :: Ptr a{- ptr. to NUL terminated string-} -> ST s [Char]
+unpackCStringST a@(Ptr addr)
+ | a == nullPtr = return []
+ | otherwise = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = return []
+ | otherwise = do
+ ls <- unpack (nh +# 1#)
+ return ((C# ch ) : ls)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackNBytesST :: Ptr a -> Int -> ST s [Char]
+unpackNBytesST (Ptr addr) (I# l) = unpackNBytesAccST# addr l []
+
+unpackNBytesAccST :: Ptr a -> Int -> [Char] -> ST s [Char]
+unpackNBytesAccST (Ptr addr) (I# l) rest = unpackNBytesAccST# addr l rest
+
+unpackNBytesST# :: Addr# -> Int# -> ST s [Char]
+unpackNBytesST# addr# l# = unpackNBytesAccST# addr# l# []
+
+unpackNBytesAccST# :: Addr# -> Int# -> [Char] -> ST s [Char]
+unpackNBytesAccST# _addr 0# rest = return rest
+unpackNBytesAccST# addr len# rest = unpack rest (len# -# 1#)
+ where
+ unpack acc i#
+ | i# <# 0# = return acc
+ | otherwise =
+ case indexCharOffAddr# addr i# of
+ ch -> unpack (C# ch : acc) (i# -# 1#)
+
+\end{code}
+
+%********************************************************
+%* *
+\subsection{Unpacking ByteArrays}
+%* *
+%********************************************************
+
+Converting byte arrays into list of chars:
+
+\begin{code}
+unpackCStringBA :: ByteArray Int -> [Char]
+unpackCStringBA (ByteArray l@(I# l#) u@(I# u#) bytes)
+ | l > u = []
+ | otherwise = unpackCStringBA# bytes (u# -# l# +# 1#)
+
+{-
+ unpack until NUL or end of BA is reached, whatever comes first.
+-}
+unpackCStringBA# :: ByteArray# -> Int# -> [Char]
+unpackCStringBA# bytes len
+ = unpack 0#
+ where
+ unpack nh
+ | nh >=# len ||
+ ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharArray# bytes nh
+
+unpackNBytesBA :: ByteArray Int -> Int -> [Char]
+unpackNBytesBA (ByteArray l u bytes) i
+ = unpackNBytesBA# bytes len#
+ where
+ len# = case max 0 (min i len) of I# v# -> v#
+ len | l > u = 0
+ | otherwise = u-l+1
+
+unpackNBytesBA# :: ByteArray# -> Int# -> [Char]
+unpackNBytesBA# _bytes 0# = []
+unpackNBytesBA# bytes len# = unpack [] (len# -# 1#)
+ where
+ unpack acc i#
+ | i# <# 0# = acc
+ | otherwise =
+ case indexCharArray# bytes i# of
+ ch -> unpack (C# ch : acc) (i# -# 1#)
+
+\end{code}
+
+
+%********************************************************
+%* *
+\subsection{Packing Strings}
+%* *
+%********************************************************
+
+Converting a list of chars into a packed @ByteArray@ representation.
+
+\begin{code}
+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
+
+\end{code}
+
+(Very :-) ``Specialised'' versions of some CharArray things...
+
+\begin{code}
+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
+{-# OPTIONS -fno-implicit-prelude -optc-DNON_POSIX_SOURCE #-}
+
+-- ---------------------------------------------------------------------------
+-- $Id: Posix.hsc,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- POSIX support layer for the standard libraries
+--
+-- NON_POSIX_SOURCE needed for the following features:
+-- * S_ISSOCK (no sockets in POSIX)
+
+module GHC.Posix where
+
+#include "HsCore.h"
+
+import Control.Monad
+
+import Foreign
+import Foreign.C
+
+import Data.Bits
+import Data.Maybe
+
+import GHC.Base
+import GHC.Num
+import GHC.Real
+import GHC.IOBase
+
+-- ---------------------------------------------------------------------------
+-- Types
+
+data CDir = CDir
+type CSigset = ()
+
+type CDev = #type dev_t
+type CIno = #type ino_t
+type CMode = #type mode_t
+type COff = #type off_t
+type CPid = #type pid_t
+
+#ifdef mingw32_TARGET_OS
+type CSsize = #type size_t
+#else
+type CGid = #type gid_t
+type CNlink = #type nlink_t
+type CSsize = #type ssize_t
+type CUid = #type uid_t
+type CCc = #type cc_t
+type CSpeed = #type speed_t
+type CTcflag = #type tcflag_t
+#endif
+
+-- ---------------------------------------------------------------------------
+-- stat()-related stuff
+
+type CStat = ()
+
+fdFileSize :: Int -> IO Integer
+fdFileSize fd =
+ allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ throwErrnoIfMinus1Retry "fdFileSize" $
+ c_fstat (fromIntegral fd) p_stat
+ c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
+ if not (s_isreg c_mode)
+ then return (-1)
+ else do
+ c_size <- (#peek struct stat, st_size) p_stat :: IO COff
+ return (fromIntegral c_size)
+
+data FDType = Directory | Stream | RegularFile
+ deriving (Eq)
+
+fileType :: FilePath -> IO FDType
+fileType file =
+ allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ withCString file $ \p_file -> do
+ throwErrnoIfMinus1Retry "fileType" $
+ c_stat p_file p_stat
+ statGetType p_stat
+
+fdType :: Int -> IO FDType
+fdType fd =
+ allocaBytes (#const sizeof(struct stat)) $ \ p_stat -> do
+ throwErrnoIfMinus1Retry "fdType" $
+ c_fstat (fromIntegral fd) p_stat
+ statGetType p_stat
+
+statGetType p_stat = do
+ c_mode <- (#peek struct stat, st_mode) p_stat :: IO CMode
+ case () of
+ _ | s_isdir c_mode -> return Directory
+ | s_isfifo c_mode || s_issock c_mode -> return Stream
+ | s_isreg c_mode -> return RegularFile
+ | otherwise -> ioException ioe_unknownfiletype
+
+
+ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
+ "unknown file type" Nothing
+
+foreign import "s_isreg_wrap" s_isreg :: CMode -> Bool
+#def inline int s_isreg_wrap(m) { return S_ISREG(m); }
+
+foreign import "s_isdir_wrap" s_isdir :: CMode -> Bool
+#def inline int s_isdir_wrap(m) { return S_ISDIR(m); }
+
+foreign import "s_isfifo_wrap" s_isfifo :: CMode -> Bool
+#def inline int s_isfifo_wrap(m) { return S_ISFIFO(m); }
+
+#ifndef mingw32_TARGET_OS
+foreign import "s_issock_wrap" s_issock :: CMode -> Bool
+#def inline int s_issock_wrap(m) { return S_ISSOCK(m); }
+#else
+s_issock :: CMode -> Bool
+s_issock cmode = False
+#endif
+-- ---------------------------------------------------------------------------
+-- Terminal-related stuff
+
+fdIsTTY :: Int -> IO Bool
+fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool
+
+#ifndef mingw32_TARGET_OS
+
+type Termios = ()
+
+setEcho :: Int -> Bool -> IO ()
+setEcho fd on = do
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setEcho"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ let new_c_lflag | on = c_lflag .|. (#const ECHO)
+ | otherwise = c_lflag .&. complement (#const ECHO)
+ (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
+ tcSetAttr fd (#const TCSANOW) p_tios
+
+getEcho :: Int -> IO Bool
+getEcho fd = do
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setEcho"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ return ((c_lflag .&. (#const ECHO)) /= 0)
+
+setCooked :: Int -> Bool -> IO ()
+setCooked fd cooked =
+ allocaBytes (#const sizeof(struct termios)) $ \p_tios -> do
+ throwErrnoIfMinus1Retry "setCooked"
+ (c_tcgetattr (fromIntegral fd) p_tios)
+
+ -- turn on/off ICANON
+ c_lflag <- (#peek struct termios, c_lflag) p_tios :: IO CTcflag
+ let new_c_lflag | cooked = c_lflag .|. (#const ICANON)
+ | otherwise = c_lflag .&. complement (#const ICANON)
+ (#poke struct termios, c_lflag) p_tios (new_c_lflag :: CTcflag)
+
+ -- set VMIN & VTIME to 1/0 respectively
+ when cooked $ do
+ let c_cc = (#ptr struct termios, c_cc) p_tios
+ vmin = c_cc `plusPtr` (#const VMIN) :: Ptr Word8
+ vtime = c_cc `plusPtr` (#const VTIME) :: Ptr Word8
+ poke vmin 1
+ poke vtime 0
+
+ tcSetAttr fd (#const TCSANOW) p_tios
+
+-- 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.
+
+tcSetAttr :: FD -> CInt -> Ptr Termios -> IO ()
+tcSetAttr fd options p_tios = do
+ allocaBytes (#const sizeof(sigset_t)) $ \ p_sigset -> do
+ allocaBytes (#const 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
+ throwErrnoIfMinus1Retry_ "tcSetAttr" $
+ c_tcsetattr (fromIntegral fd) options p_tios
+ c_sigprocmask (#const SIG_SETMASK) p_old_sigset nullPtr
+
+#else
+
+-- bogus defns for win32
+setCooked :: Int -> Bool -> IO ()
+setCooked fd cooked = return ()
+
+setEcho :: Int -> Bool -> IO ()
+setEcho fd on = return ()
+
+getEcho :: Int -> IO Bool
+getEcho fd = return False
+
+#endif
+
+-- ---------------------------------------------------------------------------
+-- Turning on non-blocking for a file descriptor
+
+#ifndef mingw32_TARGET_OS
+
+setNonBlockingFD fd = do
+ flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
+ (fcntl_read (fromIntegral fd) (#const F_GETFL))
+ throwErrnoIfMinus1Retry "setNonBlockingFD"
+ (fcntl_write (fromIntegral fd)
+ (#const F_SETFL) (flags .|. #const O_NONBLOCK))
+#else
+
+-- bogus defns for win32
+setNonBlockingFD fd = return ()
+
+#endif
+
+-- -----------------------------------------------------------------------------
+-- foreign imports
+
+foreign import "stat" unsafe
+ c_stat :: CString -> Ptr CStat -> IO CInt
+
+foreign import "fstat" unsafe
+ c_fstat :: CInt -> Ptr CStat -> IO CInt
+
+#ifdef HAVE_LSTAT
+foreign import "lstat" unsafe
+ c_lstat :: CString -> Ptr CStat -> IO CInt
+#endif
+
+foreign import "open" unsafe
+ c_open :: CString -> CInt -> CMode -> IO CInt
+
+-- POSIX flags only:
+o_RDONLY = (#const O_RDONLY) :: CInt
+o_WRONLY = (#const O_WRONLY) :: CInt
+o_RDWR = (#const O_RDWR) :: CInt
+o_APPEND = (#const O_APPEND) :: CInt
+o_CREAT = (#const O_CREAT) :: CInt
+o_EXCL = (#const O_EXCL) :: CInt
+o_TRUNC = (#const O_TRUNC) :: CInt
+
+#ifdef mingw32_TARGET_OS
+o_NOCTTY = 0 :: CInt
+o_NONBLOCK = 0 :: CInt
+#else
+o_NOCTTY = (#const O_NOCTTY) :: CInt
+o_NONBLOCK = (#const O_NONBLOCK) :: CInt
+#endif
+
+#ifdef HAVE_O_BINARY
+o_BINARY = (#const O_BINARY) :: CInt
+#endif
+
+foreign import "isatty" unsafe
+ c_isatty :: CInt -> IO CInt
+
+foreign import "close" unsafe
+ c_close :: CInt -> IO CInt
+
+foreign import "lseek" unsafe
+ c_lseek :: CInt -> COff -> CInt -> IO COff
+
+foreign import "write" unsafe
+ c_write :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
+foreign import "read" unsafe
+ c_read :: CInt -> Ptr CChar -> CSize -> IO CSsize
+
+#ifndef mingw32_TARGET_OS
+foreign import "fcntl" unsafe
+ fcntl_read :: CInt -> CInt -> IO CInt
+
+foreign import "fcntl" unsafe
+ fcntl_write :: CInt -> CInt -> CInt -> IO CInt
+
+foreign import "fork" unsafe
+ fork :: IO CPid
+
+foreign import "sigemptyset" unsafe
+ c_sigemptyset :: Ptr CSigset -> IO ()
+
+foreign import "sigaddset" unsafe
+ c_sigaddset :: Ptr CSigset -> CInt -> IO ()
+
+foreign import "sigprocmask" unsafe
+ c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO ()
+
+foreign import "tcgetattr" unsafe
+ c_tcgetattr :: CInt -> Ptr Termios -> IO CInt
+
+foreign import "tcsetattr" unsafe
+ c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt
+
+foreign import "waitpid" unsafe
+ c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
+#endif
--- /dev/null
+---------------------------------------------------------------------------
+-- PrelGHC.hi-boot
+--
+-- This hand-written interface file allows you to bring into scope the
+-- primitive operations and types that GHC knows about.
+---------------------------------------------------------------------------
+
+__interface "rts" GHCziPrim 1 0 where
+
+__export GHCziPrim
+
+ ZLzmzgZR -- (->)
+
+ CCallable
+ CReturnable
+
+-- Magical assert thingy
+ assert
+
+ -- constructor tags
+ tagToEnumzh
+ getTagzh
+ dataToTagzh
+
+ -- I/O primitives
+ RealWorld
+ realWorldzh
+ Statezh
+
+ -- Concurrency primitives
+ ThreadIdzh
+ myThreadIdzh
+ forkzh
+ yieldzh
+ killThreadzh
+ blockAsyncExceptionszh
+ unblockAsyncExceptionszh
+ delayzh
+ waitReadzh
+ waitWritezh
+
+ -- MVars
+ MVarzh
+ sameMVarzh
+ newMVarzh
+ takeMVarzh
+ putMVarzh
+ tryTakeMVarzh
+ tryPutMVarzh
+ isEmptyMVarzh
+
+ -- Parallel
+ seqzh
+ parzh
+ parGlobalzh
+ parLocalzh
+ parAtzh
+ parAtAbszh
+ parAtRelzh
+ parAtForNowzh
+
+ -- Character Type
+ Charzh
+ gtCharzh
+ geCharzh
+ eqCharzh
+ neCharzh
+ ltCharzh
+ leCharzh
+ ordzh
+ chrzh
+
+ -- Int Type
+ Intzh
+ zgzh
+ zgzezh
+ zezezh
+ zszezh
+ zlzh
+ zlzezh
+ zpzh
+ zmzh
+ ztzh
+ quotIntzh
+ remIntzh
+ gcdIntzh
+ negateIntzh
+ iShiftLzh
+ iShiftRAzh
+ iShiftRLzh
+ addIntCzh
+ subIntCzh
+ mulIntCzh
+
+ Wordzh
+ gtWordzh
+ geWordzh
+ eqWordzh
+ neWordzh
+ ltWordzh
+ leWordzh
+ plusWordzh
+ minusWordzh
+ timesWordzh
+ quotWordzh
+ remWordzh
+ andzh
+ orzh
+ notzh
+ xorzh
+ shiftLzh
+ shiftRLzh
+ int2Wordzh
+ word2Intzh
+
+ Int64zh
+ Word64zh
+
+ intToInt8zh
+ intToInt16zh
+ intToInt32zh
+ wordToWord8zh
+ wordToWord16zh
+ wordToWord32zh
+
+ Addrzh
+ gtAddrzh
+ geAddrzh
+ eqAddrzh
+ neAddrzh
+ ltAddrzh
+ leAddrzh
+ int2Addrzh
+ addr2Intzh
+
+ Floatzh
+ gtFloatzh
+ geFloatzh
+ eqFloatzh
+ neFloatzh
+ ltFloatzh
+ leFloatzh
+ plusFloatzh
+ minusFloatzh
+ timesFloatzh
+ divideFloatzh
+ negateFloatzh
+ float2Intzh
+ int2Floatzh
+ expFloatzh
+ logFloatzh
+ sqrtFloatzh
+ sinFloatzh
+ cosFloatzh
+ tanFloatzh
+ asinFloatzh
+ acosFloatzh
+ atanFloatzh
+ sinhFloatzh
+ coshFloatzh
+ tanhFloatzh
+ powerFloatzh
+ decodeFloatzh
+
+ Doublezh
+ zgzhzh
+ zgzezhzh
+ zezezhzh
+ zszezhzh
+ zlzhzh
+ zlzezhzh
+ zpzhzh
+ zmzhzh
+ ztzhzh
+ zszhzh
+ negateDoublezh
+ double2Intzh
+ int2Doublezh
+ double2Floatzh
+ float2Doublezh
+ expDoublezh
+ logDoublezh
+ sqrtDoublezh
+ sinDoublezh
+ cosDoublezh
+ tanDoublezh
+ asinDoublezh
+ acosDoublezh
+ atanDoublezh
+ sinhDoublezh
+ coshDoublezh
+ tanhDoublezh
+ ztztzhzh
+ decodeDoublezh
+
+ cmpIntegerzh
+ cmpIntegerIntzh
+ plusIntegerzh
+ minusIntegerzh
+ timesIntegerzh
+ gcdIntegerzh
+ quotIntegerzh
+ remIntegerzh
+ gcdIntegerzh
+ gcdIntegerIntzh
+ divExactIntegerzh
+ quotRemIntegerzh
+ divModIntegerzh
+ integer2Intzh
+ integer2Wordzh
+ int2Integerzh
+ word2Integerzh
+ integerToInt64zh
+ integerToWord64zh
+ int64ToIntegerzh
+ word64ToIntegerzh
+ andIntegerzh
+ orIntegerzh
+ xorIntegerzh
+ complementIntegerzh
+
+ Arrayzh
+ ByteArrayzh
+ MutableArrayzh
+ MutableByteArrayzh
+
+ sameMutableArrayzh
+ sameMutableByteArrayzh
+
+ newArrayzh
+ newByteArrayzh
+
+ indexArrayzh
+ indexCharArrayzh
+ indexWideCharArrayzh
+ indexIntArrayzh
+ indexWordArrayzh
+ indexAddrArrayzh
+ indexFloatArrayzh
+ indexDoubleArrayzh
+ indexStablePtrArrayzh
+ indexInt8Arrayzh
+ indexInt16Arrayzh
+ indexInt32Arrayzh
+ indexInt64Arrayzh
+ indexWord8Arrayzh
+ indexWord16Arrayzh
+ indexWord32Arrayzh
+ indexWord64Arrayzh
+
+ readArrayzh
+ readCharArrayzh
+ readWideCharArrayzh
+ readIntArrayzh
+ readWordArrayzh
+ readAddrArrayzh
+ readFloatArrayzh
+ readDoubleArrayzh
+ readStablePtrArrayzh
+ readInt8Arrayzh
+ readInt16Arrayzh
+ readInt32Arrayzh
+ readInt64Arrayzh
+ readWord8Arrayzh
+ readWord16Arrayzh
+ readWord32Arrayzh
+ readWord64Arrayzh
+
+ writeArrayzh
+ writeCharArrayzh
+ writeWideCharArrayzh
+ writeIntArrayzh
+ writeWordArrayzh
+ writeAddrArrayzh
+ writeFloatArrayzh
+ writeDoubleArrayzh
+ writeStablePtrArrayzh
+ writeInt8Arrayzh
+ writeInt16Arrayzh
+ writeInt32Arrayzh
+ writeInt64Arrayzh
+ writeWord8Arrayzh
+ writeWord16Arrayzh
+ writeWord32Arrayzh
+ writeWord64Arrayzh
+
+ indexCharOffAddrzh
+ indexWideCharOffAddrzh
+ indexIntOffAddrzh
+ indexWordOffAddrzh
+ indexAddrOffAddrzh
+ indexFloatOffAddrzh
+ indexDoubleOffAddrzh
+ indexStablePtrOffAddrzh
+ indexInt8OffAddrzh
+ indexInt16OffAddrzh
+ indexInt32OffAddrzh
+ indexInt64OffAddrzh
+ indexWord8OffAddrzh
+ indexWord16OffAddrzh
+ indexWord32OffAddrzh
+ indexWord64OffAddrzh
+
+ readCharOffAddrzh
+ readWideCharOffAddrzh
+ readIntOffAddrzh
+ readWordOffAddrzh
+ readAddrOffAddrzh
+ readFloatOffAddrzh
+ readDoubleOffAddrzh
+ readStablePtrOffAddrzh
+ readInt8OffAddrzh
+ readInt16OffAddrzh
+ readInt32OffAddrzh
+ readInt64OffAddrzh
+ readWord8OffAddrzh
+ readWord16OffAddrzh
+ readWord32OffAddrzh
+ readWord64OffAddrzh
+
+ writeCharOffAddrzh
+ writeWideCharOffAddrzh
+ writeIntOffAddrzh
+ writeWordOffAddrzh
+ writeAddrOffAddrzh
+ writeForeignObjOffAddrzh
+ writeFloatOffAddrzh
+ writeDoubleOffAddrzh
+ writeStablePtrOffAddrzh
+ writeInt8OffAddrzh
+ writeInt16OffAddrzh
+ writeInt32OffAddrzh
+ writeInt64OffAddrzh
+ writeWord8OffAddrzh
+ writeWord16OffAddrzh
+ writeWord32OffAddrzh
+ writeWord64OffAddrzh
+
+ indexCharOffForeignObjzh
+ indexWideCharOffForeignObjzh
+ indexIntOffForeignObjzh
+ indexWordOffForeignObjzh
+ indexAddrOffForeignObjzh
+ indexFloatOffForeignObjzh
+ indexDoubleOffForeignObjzh
+ indexStablePtrOffForeignObjzh
+ indexInt8OffForeignObjzh
+ indexInt16OffForeignObjzh
+ indexInt32OffForeignObjzh
+ indexInt64OffForeignObjzh
+ indexWord8OffForeignObjzh
+ indexWord16OffForeignObjzh
+ indexWord32OffForeignObjzh
+ indexWord64OffForeignObjzh
+
+ unsafeFreezzeArrayzh -- Note zz in the middle
+ unsafeFreezzeByteArrayzh -- Ditto
+
+ unsafeThawArrayzh
+
+ sizzeofByteArrayzh -- Ditto
+ sizzeofMutableByteArrayzh -- Ditto
+
+ MutVarzh
+ newMutVarzh
+ readMutVarzh
+ writeMutVarzh
+ sameMutVarzh
+
+ catchzh
+ raisezh
+
+ Weakzh
+ mkWeakzh
+ deRefWeakzh
+ finalizzeWeakzh
+
+ ForeignObjzh
+ mkForeignObjzh
+ writeForeignObjzh
+ foreignObjToAddrzh
+ touchzh
+
+ StablePtrzh
+ makeStablePtrzh
+ deRefStablePtrzh
+ eqStablePtrzh
+
+ StableNamezh
+ makeStableNamezh
+ eqStableNamezh
+ stableNameToIntzh
+
+ reallyUnsafePtrEqualityzh
+
+ newBCOzh
+ BCOzh
+ mkApUpd0zh
+
+ unsafeCoercezh
+ addrToHValuezh
+;
+
+-- Export GHC.Err.error, so that others don't have to import PrelErr
+__export GHCziErr error ;
+
+
+--------------------------------------------------
+instance {CCallable Charzh} = zdfCCallableCharzh;
+instance {CCallable Doublezh} = zdfCCallableDoublezh;
+instance {CCallable Floatzh} = zdfCCallableFloatzh;
+instance {CCallable Intzh} = zdfCCallableIntzh;
+instance {CCallable Addrzh} = zdfCCallableAddrzh;
+instance {CCallable Int64zh} = zdfCCallableInt64zh;
+instance {CCallable Word64zh} = zdfCCallableWord64zh;
+instance {CCallable Wordzh} = zdfCCallableWordzh;
+instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh;
+instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh;
+instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh;
+instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh;
+-- CCallable and CReturnable have kind (Type AnyBox) so that
+-- things like Int# can be instances of CCallable.
+1 class CCallable a :: ? ;
+1 class CReturnable a :: ? ;
+
+1 assert :: __forall a => GHCziBase.Bool -> a -> a ;
+
+-- These guys don't really exist:
+--
+1 zdfCCallableCharzh :: {CCallable Charzh} ;
+1 zdfCCallableDoublezh :: {CCallable Doublezh} ;
+1 zdfCCallableFloatzh :: {CCallable Floatzh} ;
+1 zdfCCallableIntzh :: {CCallable Intzh} ;
+1 zdfCCallableAddrzh :: {CCallable Addrzh} ;
+1 zdfCCallableInt64zh :: {CCallable Int64zh} ;
+1 zdfCCallableWord64zh :: {CCallable Word64zh} ;
+1 zdfCCallableWordzh :: {CCallable Wordzh} ;
+1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ;
+1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ;
+1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ;
+1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ;
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: Ptr.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- (c) The FFI Task Force, 2000
+--
+-- Module GHC.Ptr
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+module GHC.Ptr where
+
+import GHC.Base
+
+------------------------------------------------------------------------
+-- Data pointers.
+
+data Ptr a = Ptr Addr# deriving (Eq, Ord)
+
+nullPtr :: Ptr a
+nullPtr = Ptr (int2Addr# 0#)
+
+castPtr :: Ptr a -> Ptr b
+castPtr (Ptr addr) = Ptr addr
+
+plusPtr :: Ptr a -> Int -> Ptr b
+plusPtr (Ptr addr) (I# d) = Ptr (int2Addr# (addr2Int# addr +# d))
+
+alignPtr :: Ptr a -> Int -> Ptr a
+alignPtr addr@(Ptr a) (I# i)
+ = case addr2Int# a of { ai ->
+ case remInt# ai i of {
+ 0# -> addr;
+ n -> Ptr (int2Addr# (ai +# (i -# n))) }}
+
+minusPtr :: Ptr a -> Ptr b -> Int
+minusPtr (Ptr a1) (Ptr a2) = I# (addr2Int# a1 -# addr2Int# a2)
+
+instance CCallable (Ptr a)
+instance CReturnable (Ptr a)
+
+------------------------------------------------------------------------
+-- Function pointers for the default calling convention.
+
+data FunPtr a = FunPtr Addr# deriving (Eq, Ord)
+
+nullFunPtr :: FunPtr a
+nullFunPtr = FunPtr (int2Addr# 0#)
+
+castFunPtr :: FunPtr a -> FunPtr b
+castFunPtr (FunPtr addr) = FunPtr addr
+
+castFunPtrToPtr :: FunPtr a -> Ptr b
+castFunPtrToPtr (FunPtr addr) = Ptr addr
+
+castPtrToFunPtr :: Ptr a -> FunPtr b
+castPtrToFunPtr (Ptr addr) = FunPtr addr
+
+instance CCallable (FunPtr a)
+instance CReturnable (FunPtr a)
+
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Read.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Read]{Module @GHC.Read@}
+
+Instances of the Read class.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Read where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Enum ( Enum(..), maxBound )
+import GHC.Num
+import GHC.Real
+import GHC.Float
+import GHC.List
+import GHC.Maybe
+import GHC.Show -- isAlpha etc
+import GHC.Base
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Read@ class}
+%* *
+%*********************************************************
+
+Note: if you compile this with -DNEW_READS_REP, you'll get
+a (simpler) ReadS representation that only allow one valid
+parse of a string of characters, instead of a list of
+possible ones.
+
+[changing the ReadS rep has implications for the deriving
+machinery for Read, a change that hasn't been made, so you
+probably won't want to compile in this new rep. except
+when in an experimental mood.]
+
+\begin{code}
+
+#ifndef NEW_READS_REP
+type ReadS a = String -> [(a,String)]
+#else
+type ReadS a = String -> Maybe (a,String)
+#endif
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+
+ readList :: ReadS [a]
+ readList = readList__ reads
+\end{code}
+
+In this module we treat [(a,String)] as a monad in Control.MonadPlus
+But Control.MonadPlus isn't defined yet, so we simply give local
+declarations for mzero and guard suitable for this particular
+type. It would also be reasonably to move Control.MonadPlus to GHC.Base
+along with Control.Monad and Functor, but that seems overkill for one
+example
+
+\begin{code}
+mzero :: [a]
+mzero = []
+
+guard :: Bool -> [()]
+guard True = [()]
+guard False = []
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Utility functions}
+%* *
+%*********************************************************
+
+\begin{code}
+reads :: (Read a) => ReadS a
+reads = readsPrec 0
+
+read :: (Read a) => String -> a
+read s =
+ case read_s s of
+#ifndef NEW_READS_REP
+ [x] -> x
+ [] -> error "Prelude.read: no parse"
+ _ -> error "Prelude.read: ambiguous parse"
+#else
+ Just x -> x
+ Nothing -> error "Prelude.read: no parse"
+#endif
+ where
+ read_s str = do
+ (x,str1) <- reads str
+ ("","") <- lex str1
+ return x
+\end{code}
+
+\begin{code}
+readParen :: Bool -> ReadS a -> ReadS a
+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)
+
+
+readList__ :: ReadS a -> ReadS [a]
+
+readList__ readx
+ = readParen False (\r -> do
+ ("[",s) <- lex r
+ readl s)
+ where readl s =
+ (do { ("]",t) <- lex s ; return ([],t) }) ++
+ (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) })
+
+ readl2 s =
+ (do { ("]",t) <- lex s ; return ([],t) }) ++
+ (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) })
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Lexical analysis}
+%* *
+%*********************************************************
+
+This lexer is not completely faithful to the Haskell lexical syntax.
+Current limitations:
+ Qualified names are not handled properly
+ A `--' does not terminate a symbol
+ Octal and hexidecimal numerics are not recognized as a single token
+
+\begin{code}
+lex :: ReadS String
+
+lex "" = return ("","")
+lex (c:s) | isSpace c = lex (dropWhile isSpace s)
+lex ('\'':s) = do
+ (ch, '\'':t) <- lexLitChar s
+ guard (ch /= "'")
+ return ('\'':ch++"'", t)
+lex ('"':s) = do
+ (str,t) <- lexString s
+ return ('"':str, t)
+
+ where
+ lexString ('"':s) = return ("\"",s)
+ lexString s = do
+ (ch,t) <- lexStrItem s
+ (str,u) <- lexString t
+ return (ch++str, u)
+
+
+ lexStrItem ('\\':'&':s) = return ("\\&",s)
+ lexStrItem ('\\':c:s) | isSpace c = do
+ ('\\':t) <- return (dropWhile isSpace s)
+ return ("\\&",t)
+ lexStrItem s = lexLitChar s
+
+lex (c:s) | isSingle c = return ([c],s)
+ | isSym c = do
+ (sym,t) <- return (span isSym s)
+ return (c:sym,t)
+ | isAlpha c = do
+ (nam,t) <- return (span isIdChar s)
+ return (c:nam, t)
+ | isDigit c = do
+{- Removed, 13/03/2000 by SDM.
+ Doesn't work, and not required by Haskell report.
+ let
+ (pred, s', isDec) =
+ case s of
+ ('o':rs) -> (isOctDigit, rs, False)
+ ('O':rs) -> (isOctDigit, rs, False)
+ ('x':rs) -> (isHexDigit, rs, False)
+ ('X':rs) -> (isHexDigit, rs, False)
+ _ -> (isDigit, s, True)
+-}
+ (ds,s) <- return (span isDigit s)
+ (fe,t) <- lexFracExp s
+ return (c:ds++fe,t)
+ | otherwise = mzero -- bad character
+ where
+ isSingle c = c `elem` ",;()[]{}_`"
+ isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
+ isIdChar c = isAlphaNum c || c `elem` "_'"
+
+ lexFracExp ('.':c:cs) | isDigit c = do
+ (ds,t) <- lex0Digits cs
+ (e,u) <- lexExp t
+ return ('.':c:ds++e,u)
+ lexFracExp s = return ("",s)
+
+ lexExp (e:s) | e `elem` "eE" =
+ (do
+ (c:t) <- return s
+ guard (c `elem` "+-")
+ (ds,u) <- lexDecDigits t
+ return (e:c:ds,u)) ++
+ (do
+ (ds,t) <- lexDecDigits s
+ return (e:ds,t))
+
+ lexExp s = return ("",s)
+
+lexDigits :: ReadS String
+lexDigits = lexDecDigits
+
+lexDecDigits :: ReadS String
+lexDecDigits = nonnull isDigit
+
+lexOctDigits :: ReadS String
+lexOctDigits = nonnull isOctDigit
+
+lexHexDigits :: ReadS String
+lexHexDigits = nonnull isHexDigit
+
+-- 0 or more digits
+lex0Digits :: ReadS String
+lex0Digits s = return (span isDigit s)
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = do
+ (cs@(_:_),t) <- return (span p s)
+ return (cs,t)
+
+lexLitChar :: ReadS String
+lexLitChar ('\\':s) = do
+ (esc,t) <- lexEsc s
+ return ('\\':esc, t)
+ where
+ lexEsc (c:s) | c `elem` escChars = return ([c],s)
+ lexEsc s@(d:_) | isDigit d = checkSize 10 lexDecDigits s
+ lexEsc ('o':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s)
+ lexEsc ('O':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s)
+ lexEsc ('x':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s)
+ lexEsc ('X':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s)
+ lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report.
+ lexEsc s@(c:_) | isUpper c = fromAsciiLab s
+ lexEsc _ = mzero
+
+ escChars = "abfnrtv\\\"'"
+
+ fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) &&
+ [x,y,z] `elem` asciiEscTab = return ([x,y,z], ls)
+ fromAsciiLab (x:y:ls) | isUpper y &&
+ [x,y] `elem` asciiEscTab = return ([x,y], ls)
+ fromAsciiLab _ = mzero
+
+ asciiEscTab = "DEL" : asciiTab
+
+ {-
+ Check that the numerically escaped char literals are
+ within accepted boundaries.
+
+ Note: this allows char lits with leading zeros, i.e.,
+ \0000000000000000000000000000001.
+ -}
+ checkSize base f str = do
+ (num, res) <- f str
+ if toAnInteger base num > toInteger (ord maxBound) then
+ mzero
+ else
+ case base of
+ 8 -> return ('o':num, res)
+ 16 -> return ('x':num, res)
+ _ -> return (num, res)
+
+ toAnInteger base = foldl (\ acc n -> acc*base + toInteger (digitToInt n)) 0
+
+
+lexLitChar (c:s) = return ([c],s)
+lexLitChar "" = mzero
+
+digitToInt :: Char -> Int
+digitToInt c
+ | isDigit c = fromEnum c - fromEnum '0'
+ | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Instances of @Read@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Read Char where
+ readsPrec _ = readParen False
+ (\r -> do
+ ('\'':s,t) <- lex r
+ (c,"\'") <- readLitChar s
+ return (c,t))
+
+ readList = readParen False (\r -> do
+ ('"':s,t) <- lex r
+ (l,_) <- readl s
+ return (l,t))
+ where readl ('"':s) = return ("",s)
+ readl ('\\':'&':s) = readl s
+ readl s = do
+ (c,t) <- readLitChar s
+ (cs,u) <- readl t
+ return (c:cs,u)
+
+instance Read Bool where
+ readsPrec _ = readParen False
+ (\r ->
+ lex r >>= \ lr ->
+ (do { ("True", rest) <- return lr ; return (True, rest) }) ++
+ (do { ("False", rest) <- return lr ; return (False, rest) }))
+
+
+instance Read Ordering where
+ readsPrec _ = readParen False
+ (\r ->
+ lex r >>= \ lr ->
+ (do { ("LT", rest) <- return lr ; return (LT, rest) }) ++
+ (do { ("EQ", rest) <- return lr ; return (EQ, rest) }) ++
+ (do { ("GT", rest) <- return lr ; return (GT, rest) }))
+
+instance Read a => Read (Maybe a) where
+ readsPrec _ = readParen False
+ (\r ->
+ lex r >>= \ lr ->
+ (do { ("Nothing", rest) <- return lr ; return (Nothing, rest)}) ++
+ (do
+ ("Just", rest1) <- return lr
+ (x, rest2) <- reads rest1
+ return (Just x, rest2)))
+
+instance (Read a, Read b) => Read (Either a b) where
+ readsPrec _ = readParen False
+ (\r ->
+ lex r >>= \ lr ->
+ (do
+ ("Left", rest1) <- return lr
+ (x, rest2) <- reads rest1
+ return (Left x, rest2)) ++
+ (do
+ ("Right", rest1) <- return lr
+ (x, rest2) <- reads rest1
+ return (Right x, rest2)))
+
+instance Read Int where
+ readsPrec _ x = readSigned readDec x
+
+instance Read Integer where
+ readsPrec _ x = readSigned readDec x
+
+instance Read Float where
+ readsPrec _ x = readSigned readFloat x
+
+instance Read Double where
+ readsPrec _ x = readSigned readFloat x
+
+instance (Integral a, Read a) => Read (Ratio a) where
+ readsPrec p = readParen (p > ratio_prec)
+ (\r -> do
+ (x,s) <- reads r
+ ("%",t) <- lex s
+ (y,u) <- reads t
+ return (x%y,u))
+
+instance (Read a) => Read [a] where
+ readsPrec _ = readList
+
+instance Read () where
+ readsPrec _ = readParen False
+ (\r -> do
+ ("(",s) <- lex r
+ (")",t) <- lex s
+ return ((),t))
+
+instance (Read a, Read b) => Read (a,b) where
+ readsPrec _ = readParen False
+ (\r -> do
+ ("(",s) <- lex r
+ (x,t) <- readsPrec 0 s
+ (",",u) <- lex t
+ (y,v) <- readsPrec 0 u
+ (")",w) <- lex v
+ return ((x,y), w))
+
+instance (Read a, Read b, Read c) => Read (a, b, c) where
+ readsPrec _ = readParen False
+ (\a -> do
+ ("(",b) <- lex a
+ (x,c) <- readsPrec 0 b
+ (",",d) <- lex c
+ (y,e) <- readsPrec 0 d
+ (",",f) <- lex e
+ (z,g) <- readsPrec 0 f
+ (")",h) <- lex g
+ return ((x,y,z), h))
+
+instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
+ readsPrec _ = readParen False
+ (\a -> do
+ ("(",b) <- lex a
+ (w,c) <- readsPrec 0 b
+ (",",d) <- lex c
+ (x,e) <- readsPrec 0 d
+ (",",f) <- lex e
+ (y,g) <- readsPrec 0 f
+ (",",h) <- lex g
+ (z,h) <- readsPrec 0 h
+ (")",i) <- lex h
+ return ((w,x,y,z), i))
+
+instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
+ readsPrec _ = readParen False
+ (\a -> do
+ ("(",b) <- lex a
+ (v,c) <- readsPrec 0 b
+ (",",d) <- lex c
+ (w,e) <- readsPrec 0 d
+ (",",f) <- lex e
+ (x,g) <- readsPrec 0 f
+ (",",h) <- lex g
+ (y,i) <- readsPrec 0 h
+ (",",j) <- lex i
+ (z,k) <- readsPrec 0 j
+ (")",l) <- lex k
+ return ((v,w,x,y,z), l))
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Reading characters}
+%* *
+%*********************************************************
+
+\begin{code}
+readLitChar :: ReadS Char
+
+readLitChar [] = mzero
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = return ('\a',s)
+ readEsc ('b':s) = return ('\b',s)
+ readEsc ('f':s) = return ('\f',s)
+ readEsc ('n':s) = return ('\n',s)
+ readEsc ('r':s) = return ('\r',s)
+ readEsc ('t':s) = return ('\t',s)
+ readEsc ('v':s) = return ('\v',s)
+ readEsc ('\\':s) = return ('\\',s)
+ readEsc ('"':s) = return ('"',s)
+ readEsc ('\'':s) = return ('\'',s)
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = return (chr (ord c - ord '@'), s)
+ readEsc s@(d:_) | isDigit d
+ = do
+ (n,t) <- readDec s
+ return (chr n,t)
+ readEsc ('o':s) = do
+ (n,t) <- readOct s
+ return (chr n,t)
+ readEsc ('x':s) = do
+ (n,t) <- readHex s
+ return (chr n,t)
+
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [match mne s]]
+ of (pr:_) -> return pr
+ [] -> mzero
+ readEsc _ = mzero
+
+readLitChar (c:s) = return (c,s)
+
+match :: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y = match xs ys
+match xs ys = (xs,ys)
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Reading numbers}
+%* *
+%*********************************************************
+
+Note: reading numbers at bases different than 10, does not
+include lexing common prefixes such as '0x' or '0o' etc.
+
+\begin{code}
+{-# SPECIALISE readDec ::
+ ReadS Int,
+ ReadS Integer #-}
+readDec :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit (\d -> ord d - ord '0')
+
+{-# SPECIALISE readOct ::
+ ReadS Int,
+ ReadS Integer #-}
+readOct :: (Integral a) => ReadS a
+readOct = readInt 8 isOctDigit (\d -> ord d - ord '0')
+
+{-# SPECIALISE readHex ::
+ ReadS Int,
+ ReadS Integer #-}
+readHex :: (Integral a) => ReadS a
+readHex = readInt 16 isHexDigit hex
+ where hex d = ord d - (if isDigit d then ord '0'
+ else ord (if isUpper d then 'A' else 'a') - 10)
+
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s = do
+ (ds,r) <- nonnull isDig s
+ return (foldl1 (\n d -> n * radix + d)
+ (map (fromInteger . toInteger . digToInt) ds), r)
+
+{-# SPECIALISE readSigned ::
+ ReadS Int -> ReadS Int,
+ ReadS Integer -> ReadS Integer,
+ ReadS Double -> ReadS Double #-}
+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)
+\end{code}
+
+The functions readFloat below uses rational arithmetic
+to ensure correct conversion between the floating-point radix and
+decimal. It is often possible to use a higher-precision floating-
+point type to obtain the same results.
+
+\begin{code}
+{-# SPECIALISE readFloat ::
+ ReadS Double,
+ ReadS Float #-}
+readFloat :: (RealFloat a) => ReadS a
+readFloat r = do
+ (x,t) <- readRational r
+ return (fromRational x,t)
+
+readRational :: ReadS Rational -- NB: doesn't handle leading "-"
+
+readRational r =
+ (do
+ (n,d,s) <- readFix r
+ (k,t) <- readExp s
+ return ((n%1)*10^^(k-d), t )) ++
+ (do
+ ("NaN",t) <- lex r
+ return (0/0,t) ) ++
+ (do
+ ("Infinity",t) <- lex r
+ return (1/0,t) )
+ where
+ readFix r = do
+ (ds,s) <- lexDecDigits r
+ (ds',t) <- lexDotDigits s
+ return (read (ds++ds'), length ds', t)
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = return (0,s)
+
+ readExp' ('+':s) = readDec s
+ readExp' ('-':s) = do
+ (k,t) <- readDec s
+ return (-k,t)
+ readExp' s = readDec s
+
+ lexDotDigits ('.':s) = lex0Digits s
+ lexDotDigits s = return ("",s)
+
+readRational__ :: String -> Rational -- we export this one (non-std)
+ -- NB: *does* handle a leading "-"
+readRational__ top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case (do { (x,t) <- readRational s ; ("","") <- lex t ; return x }) of
+#ifndef NEW_READS_REP
+ [x] -> x
+ [] -> error ("readRational__: no parse:" ++ top_s)
+ _ -> error ("readRational__: ambiguous parse:" ++ top_s)
+#else
+ Just x -> x
+ Nothing -> error ("readRational__: no parse:" ++ top_s)
+#endif
+
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Real.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1994-2000
+%
+
+\section[GHC.Real]{Module @GHC.Real@}
+
+The types
+
+ Ratio, Rational
+
+and the classes
+
+ Real
+ Integral
+ Fractional
+ RealFrac
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+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`
+
+default () -- Double isn't available yet,
+ -- and we shouldn't be using defaults anyway
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Ratio@ and @Rational@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
+type Rational = Ratio Integer
+\end{code}
+
+
+\begin{code}
+{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
+(%) :: (Integral a) => a -> a -> Ratio a
+numerator, 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
+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
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot, rem, div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ 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
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+
+ recip x = 1 / x
+ x / y = x * recip y
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, 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
+
+ -- Following chks for zero divisor are non-standard (WDP)
+ a `quot` b = if b /= 0
+ then a `quotInt` b
+ else error "Prelude.Integral.quot{Int}: divide by 0"
+ a `rem` b = if b /= 0
+ then a `remInt` b
+ else error "Prelude.Integral.rem{Int}: divide by 0"
+
+ x `div` y = x `divInt` y
+ x `mod` y = x `modInt` y
+
+ a `quotRem` b = a `quotRemInt` b
+ a `divMod` b = 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
+
+ n `quot` d = n `quotInteger` d
+ n `rem` d = n `remInteger` d
+
+ n `div` d = q where (q,_) = divMod n d
+ n `mod` d = r where (_,r) = divMod n d
+
+ a `divMod` b = a `divModInteger` b
+ a `quotRem` b = a `quotRemInteger` b
+\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) = if x < 0 then (-y) :% (-x) else 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 > ratio_prec)
+ (shows x . showString " % " . shows y)
+
+ratio_prec :: Int
+ratio_prec = 7
+
+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}
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+{-# RULES
+"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int
+ #-}
+
+realToFrac :: (Real a, Fractional b) => a -> b
+realToFrac = fromRational . toRational
+
+{-# RULES
+"realToFrac/Int->Int" realToFrac = id :: Int -> Int
+ #-}
+
+-- For backward compatibility
+{-# DEPRECATED fromInt "use fromIntegral instead" #-}
+fromInt :: Num a => Int -> a
+fromInt = fromIntegral
+
+-- For backward compatibility
+{-# DEPRECATED toInt "use fromIntegral instead" #-}
+toInt :: Integral a => a -> Int
+toInt = fromIntegral
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Overloaded numeric functions}
+%* *
+%*********************************************************
+
+\begin{code}
+showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> 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
+
+-------------------------------------------------------
+{-# 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"
+
+{-# 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 :: (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 :: (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
+% ------------------------------------------------------------------------------
+% $Id: ST.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+
+\section[GHC.ST]{The @ST@ monad}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+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}
+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 #)
+ )
+
+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.
+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 100" says.
+-- SLPJ Apr 99
+{-# INLINE 100 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 -fno-implicit-prelude #-}
+module GHC.STRef where
+
+import GHC.ST
+import GHC.Prim
+import GHC.Base
+
+data STRef s a = STRef (MutVar# s a)
+
+newSTRef :: a -> ST s (STRef s a)
+newSTRef init = ST $ \s1# ->
+ case newMutVar# init s1# of { (# s2#, var# #) ->
+ (# s2#, STRef var# #) }
+
+readSTRef :: STRef s a -> ST s a
+readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1#
+
+writeSTRef :: STRef s a -> a -> ST s ()
+writeSTRef (STRef var#) val = ST $ \s1# ->
+ case writeMutVar# var# val s1# of { s2# ->
+ (# s2#, () #) }
+
+modifySTRef :: STRef s a -> (a -> a) -> ST s ()
+modifySTRef ref f = readSTRef ref >>= writeSTRef ref . f
+
+-- Just pointer equality on mutable references:
+instance Eq (STRef s a) where
+ STRef v1# == STRef v2# = sameMutVar# v1# v2#
+\end{code}
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Show.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+
+\section{Module @GHC.Show@}
+
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+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,
+
+ -- Character operations
+ isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
+ isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ toUpper, toLower,
+ asciiTab,
+
+ -- String operations
+ lines, unlines, words, unwords
+ )
+ where
+
+import {-# SOURCE #-} GHC.Err ( error )
+import GHC.Base
+import GHC.Tup
+import GHC.Maybe
+import GHC.List ( (!!), break, dropWhile
+#ifdef USE_REPORT_PRELUDE
+ , concatMap, foldr1
+#endif
+ )
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{The @Show@ class}
+%* *
+%*********************************************************
+
+\begin{code}
+type ShowS = String -> String
+
+class Show a where
+ showsPrec :: Int -> a -> ShowS
+ show :: a -> String
+ 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)
+\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 (I# p#) (Just x) s
+ = (showParen (p# >=# 10#) $
+ showString "Just " .
+ showsPrec (I# 10#) x) s
+
+instance (Show a, Show b) => Show (Either a b) where
+ showsPrec (I# p#) e s =
+ (showParen (p# >=# 10#) $
+ case e of
+ Left a -> showString "Left " . showsPrec (I# 10#) a
+ Right b -> showString "Right " . showsPrec (I# 10#) 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 _ (x,y) s = (showChar '(' . shows x . showChar ',' .
+ shows y . showChar ')')
+ s
+
+instance (Show a, Show b, Show c) => Show (a, b, c) where
+ showsPrec _ (x,y,z) s = (showChar '(' . shows x . showChar ',' .
+ shows y . showChar ',' .
+ shows z . showChar ')')
+ s
+
+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+ showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' .
+ shows x . showChar ',' .
+ shows y . showChar ',' .
+ shows z . showChar ')')
+ s
+
+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
+ showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' .
+ shows w . showChar ',' .
+ shows x . showChar ',' .
+ shows y . showChar ',' .
+ shows z . showChar ')')
+ s
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Support code for @Show@}
+%* *
+%*********************************************************
+
+\begin{code}
+shows :: (Show a) => a -> ShowS
+shows = showsPrec zeroInt
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+showString = (++)
+
+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}
+showLitChar :: Char -> ShowS
+showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDigit (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
+
+protectEsc :: (Char -> Bool) -> ShowS -> ShowS
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+intToDigit :: Int -> Char
+intToDigit (I# i)
+ | i >=# 0# && i <=# 9# = unsafeChr (ord '0' `plusInt` I# i)
+ | i >=# 10# && i <=# 15# = unsafeChr (ord 'a' `minusInt` I# 10# `plusInt` I# i)
+ | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i))
+
+\end{code}
+
+Code specific for Ints.
+
+\begin{code}
+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
+ n'# = negateInt# n#
+ in if n'# <# 0# -- minInt?
+ then '-' : itos' (negateInt# (n'# `quotInt#` 10#))
+ (itos' (negateInt# (n'# `remInt#` 10#)) cs)
+ else '-' : itos' n'# cs
+ | otherwise = itos' n# cs
+ where
+ itos' :: Int# -> String -> String
+ itos' n# cs
+ | n# <# 10# = C# (chr# (ord# '0'# +# n#)) : cs
+ | otherwise = itos' (n# `quotInt#` 10#)
+ (C# (chr# (ord# '0'# +# (n# `remInt#` 10#))) : cs)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Character stuff}
+%* *
+%*********************************************************
+
+\begin{code}
+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
+ isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ isAsciiUpper, isAsciiLower :: Char -> Bool
+isAscii c = c < '\x80'
+isLatin1 c = c <= '\xff'
+isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
+isPrint c = not (isControl c)
+
+-- 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'
+
+-- 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'
+isAsciiLower c = c >= 'a' && c <= 'z'
+isAsciiUpper c = c >= 'A' && c <= 'Z'
+
+isAlpha c = isLower c || isUpper c
+isDigit c = c >= '0' && c <= '9'
+isOctDigit c = c >= '0' && c <= '7'
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
+ c >= 'a' && c <= 'f'
+isAlphaNum c = isAlpha c || isDigit c
+
+-- Case-changing operations
+
+toUpper, toLower :: Char -> Char
+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
+
+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}
+
+%*********************************************************
+%* *
+\subsection{Functions on strings}
+%* *
+%*********************************************************
+
+lines breaks a string up into a list of strings at newline characters.
+The resulting strings do not contain newlines. Similary, words
+breaks a string up into a list of words, which were delimited by
+white space. unlines and unwords are the inverse operations.
+unlines joins lines with terminating newlines, and unwords joins
+words with separating spaces.
+
+\begin{code}
+lines :: String -> [String]
+lines "" = []
+lines s = let (l, s') = break (== '\n') s
+ in l : case s' of
+ [] -> []
+ (_:s'') -> lines s''
+
+words :: String -> [String]
+words s = case dropWhile {-partain:Char.-}isSpace s of
+ "" -> []
+ s' -> w : words s''
+ where (w, s'') =
+ break {-partain:Char.-}isSpace s'
+
+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
+
+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
+
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Stable.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The GHC Team, 1992-2000
+%
+
+\section{Module @GHC.Stable@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+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 Foreign.Ptr
+
+import GHC.Base
+import GHC.IOBase
+
+-----------------------------------------------------------------------------
+-- Stable Pointers
+
+data StablePtr a = StablePtr (StablePtr# a)
+
+instance CCallable (StablePtr a)
+instance CReturnable (StablePtr a)
+
+newStablePtr :: a -> IO (StablePtr a)
+newStablePtr a = IO $ \ s ->
+ case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)
+
+deRefStablePtr :: StablePtr a -> IO a
+deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s
+
+foreign import unsafe freeStablePtr :: StablePtr a -> IO ()
+
+castStablePtrToPtr :: StablePtr a -> Ptr ()
+castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s)
+
+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
+% -----------------------------------------------------------------------------
+% $Id: Storable.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+A class for primitive marshaling
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude -monly-3-regs #-}
+
+#include "MachDeps.h"
+
+module GHC.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 ()
+ destruct) -- :: Ptr a -> IO ()
+ ) where
+\end{code}
+
+\begin{code}
+import Control.Monad ( liftM )
+import Foreign.C.Types
+import Foreign.C.TypesISO
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Stable ( StablePtr )
+import GHC.Num
+import GHC.Int
+import GHC.Word
+import GHC.Stable
+import Foreign.Ptr
+import GHC.Float
+import GHC.Err
+import GHC.IOBase
+import GHC.Base
+#endif
+\end{code}
+
+Primitive marshaling
+
+Minimal complete definition: sizeOf, alignment, and one definition
+in each of the peek/poke families.
+
+\begin{code}
+class Storable a where
+
+ -- sizeOf/alignment *never* use their first argument
+ sizeOf :: a -> Int
+ alignment :: a -> Int
+
+ -- replacement for read-/write???OffAddr
+ peekElemOff :: Ptr a -> Int -> IO a
+ pokeElemOff :: Ptr a -> Int -> a -> IO ()
+
+ -- the same with *byte* offsets
+ peekByteOff :: Ptr b -> Int -> IO a
+ pokeByteOff :: Ptr b -> Int -> a -> IO ()
+
+ -- ... and with no offsets at all
+ peek :: Ptr a -> IO a
+ poke :: Ptr a -> a -> IO ()
+
+ -- free memory associated with the object
+ -- (except the object pointer itself)
+ destruct :: Ptr a -> IO ()
+
+ -- circular default instances
+ peekElemOff = peekElemOff_ undefined
+ where peekElemOff_ :: a -> Ptr a -> Int -> IO a
+ peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef)
+ 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
+
+ destruct _ = return ()
+\end{code}
+
+System-dependent, but rather obvious instances
+
+\begin{code}
+instance Storable Bool where
+ sizeOf _ = sizeOf (undefined::CInt)
+ alignment _ = alignment (undefined::CInt)
+ peekElemOff p i = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i
+ pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt)
+
+#define STORABLE(T,size,align,read,write) \
+instance Storable (T) where { \
+ sizeOf _ = size; \
+ alignment _ = align; \
+ peekElemOff = read; \
+ pokeElemOff = write }
+
+STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32,
+ readWideCharOffPtr,writeWideCharOffPtr)
+
+STORABLE(Int,SIZEOF_LONG,ALIGNMENT_LONG,
+ readIntOffPtr,writeIntOffPtr)
+
+STORABLE(Word,SIZEOF_LONG,ALIGNMENT_LONG,
+ readWordOffPtr,writeWordOffPtr)
+
+STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
+ readPtrOffPtr,writePtrOffPtr)
+
+STORABLE((FunPtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
+ readFunPtrOffPtr,writeFunPtrOffPtr)
+
+STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
+ readStablePtrOffPtr,writeStablePtrOffPtr)
+
+STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT,
+ readFloatOffPtr,writeFloatOffPtr)
+
+STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE,
+ 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)
+
+#define NSTORABLE(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 }
+
+NSTORABLE(CChar)
+NSTORABLE(CSChar)
+NSTORABLE(CUChar)
+NSTORABLE(CShort)
+NSTORABLE(CUShort)
+NSTORABLE(CInt)
+NSTORABLE(CUInt)
+NSTORABLE(CLong)
+NSTORABLE(CULong)
+NSTORABLE(CLLong)
+NSTORABLE(CULLong)
+NSTORABLE(CFloat)
+NSTORABLE(CDouble)
+NSTORABLE(CLDouble)
+NSTORABLE(CPtrdiff)
+NSTORABLE(CSize)
+NSTORABLE(CWchar)
+NSTORABLE(CSigAtomic)
+NSTORABLE(CClock)
+NSTORABLE(CTime)
+\end{code}
+
+Helper functions
+
+\begin{code}
+#ifdef __GLASGOW_HASKELL__
+
+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 #)
+readInt16OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #)
+readInt32OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #)
+readInt64OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #)
+readWord8OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #)
+readWord16OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #)
+readWord32OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# 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, () #)
+writeInt16OffPtr (Ptr a) (I# i) (I16# x)
+ = IO $ \s -> case writeInt16OffAddr# 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, () #)
+writeInt64OffPtr (Ptr a) (I# i) (I64# x)
+ = IO $ \s -> case writeInt64OffAddr# 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, () #)
+writeWord16OffPtr (Ptr a) (I# i) (W16# x)
+ = IO $ \s -> case writeWord16OffAddr# 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, () #)
+writeWord64OffPtr (Ptr a) (I# i) (W64# x)
+ = IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #)
+
+#endif /* __GLASGOW_HASKELL__ */
+\end{code}
--- /dev/null
+-- -----------------------------------------------------------------------------
+-- $Id: TopHandler.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+--
+-- (c) The University of Glasgow, 2001
+--
+-- GHC.TopHandler
+--
+-- 'Top-level' IO actions want to catch exceptions (e.g., forkIO and
+-- GHC.Main.mainIO) and report them - topHandler is the exception
+-- handler they should use for this:
+
+-- make sure we handle errors while reporting the error!
+-- (e.g. evaluating the string passed to 'error' might generate
+-- another error, etc.)
+
+-- These functions can't go in GHC.Main, because GHC.Main isn't
+-- included in HSstd.o (because GHC.Main depends on Main, which
+-- doesn't exist yet...).
+
+\begin{code}
+module GHC.TopHandler (
+ topHandler, reportStackOverflow, reportError
+ ) where
+
+import Prelude
+
+import System.IO
+
+import Foreign.C.String
+import Foreign.Ptr
+import GHC.IOBase
+import GHC.Exception
+
+topHandler :: Exception -> IO ()
+topHandler err = catchException (real_handler err) topHandler
+
+real_handler :: Exception -> IO ()
+real_handler ex =
+ case ex of
+ AsyncException StackOverflow -> reportStackOverflow True
+
+ -- only the main thread gets ExitException exceptions
+ ExitException ExitSuccess -> shutdownHaskellAndExit 0
+ ExitException (ExitFailure n) -> shutdownHaskellAndExit n
+
+ ErrorCall s -> reportError True s
+ other -> reportError True (showsPrec 0 other "\n")
+
+-- NOTE: shutdownHaskellAndExit must be called "safe", because it *can*
+-- re-enter Haskell land through finalizers.
+foreign import ccall "shutdownHaskellAndExit"
+ shutdownHaskellAndExit :: Int -> IO ()
+
+reportStackOverflow :: Bool -> IO ()
+reportStackOverflow bombOut = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ callStackOverflowHook
+ if bombOut then
+ stg_exit 2
+ else
+ return ()
+
+reportError :: Bool -> String -> IO ()
+reportError bombOut str = do
+ (hFlush stdout) `catchException` (\ _ -> return ())
+ withCStringLen str $ \(cstr,len) -> do
+ writeErrString addrOf_ErrorHdrHook cstr len
+ if bombOut
+ then stg_exit 1
+ else return ()
+
+foreign import ccall "addrOf_ErrorHdrHook" unsafe
+ addrOf_ErrorHdrHook :: Ptr ()
+
+foreign import ccall "writeErrString__" unsafe
+ writeErrString :: Ptr () -> CString -> Int -> IO ()
+
+-- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove
+-- the unsafe below.
+foreign import ccall "stackOverflow" unsafe
+ callStackOverflowHook :: IO ()
+
+foreign import ccall "stg_exit" unsafe
+ stg_exit :: Int -> IO ()
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: Tup.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1992-2000
+%
+
+\section[GHC.Tup]{Module @GHC.Tup@}
+
+This modules defines the typle data types.
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Tup where
+
+import GHC.Base
+
+default () -- Double isn't available yet
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Other tuple types}
+%* *
+%*********************************************************
+
+\begin{code}
+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
+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g
+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h
+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i
+data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j
+data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k
+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
+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
+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
+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
+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___
+-}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Standard functions over tuples}
+* *
+%*********************************************************
+
+\begin{code}
+fst :: (a,b) -> a
+fst (x,_) = x
+
+snd :: (a,b) -> b
+snd (_,y) = y
+
+-- curry converts an uncurried function to a curried function;
+-- uncurry converts a curried function to a function on pairs.
+curry :: ((a, b) -> c) -> a -> b -> c
+curry f x y = f (x, y)
+
+uncurry :: (a -> b -> c) -> ((a, b) -> c)
+uncurry f p = f (fst p) (snd p)
+\end{code}
+
--- /dev/null
+% ------------------------------------------------------------------------------
+% $Id: Weak.lhs,v 1.1 2001/06/28 14:15:03 simonmar Exp $
+%
+% (c) The University of Glasgow, 1998-2000
+%
+
+\section[GHC.Weak]{Module @GHC.Weak@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+module GHC.Weak where
+
+import GHC.Prim
+import GHC.Base
+import GHC.Maybe
+import GHC.IOBase ( IO(..), unIO )
+
+data Weak v = Weak (Weak# v)
+
+mkWeak :: k -- key
+ -> v -- value
+ -> Maybe (IO ()) -- finalizer
+ -> IO (Weak v) -- weak pointer
+
+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 #) }
+
+mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k)
+mkWeakPtr key finalizer = mkWeak key key finalizer
+
+addFinalizer :: key -> IO () -> IO ()
+addFinalizer key finalizer = do
+ mkWeakPtr key (Just finalizer) -- throw it away
+ return ()
+
+{-
+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
+%
+% (c) The University of Glasgow, 1997-2001
+%
+\section[GHC.Word]{Module @GHC.Word@}
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+#include "MachDeps.h"
+
+module GHC.Word (
+ Word(..), Word8(..), Word16(..), Word32(..), Word64(..),
+ divZeroError, toEnumError, fromEnumError, succError, predError)
+ where
+
+import Data.Bits
+
+import GHC.Base
+import GHC.Enum
+import GHC.Num
+import GHC.Real
+import GHC.Read
+import GHC.Arr
+import GHC.Show
+
+------------------------------------------------------------------------
+-- Helper functions
+------------------------------------------------------------------------
+
+{-# NOINLINE divZeroError #-}
+divZeroError :: (Show a) => String -> a -> b
+divZeroError meth x =
+ error $ "Integral." ++ meth ++ ": divide by 0 (" ++ show x ++ " / 0)"
+
+{-# 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 CCallable Word
+instance CReturnable Word
+
+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 "quot{Word}" x
+ rem x@(W# x#) y@(W# y#)
+ | y /= 0 = W# (x# `remWord#` y#)
+ | otherwise = divZeroError "rem{Word}" x
+ div x@(W# x#) y@(W# y#)
+ | y /= 0 = W# (x# `quotWord#` y#)
+ | otherwise = divZeroError "div{Word}" x
+ mod x@(W# x#) y@(W# y#)
+ | y /= 0 = W# (x# `remWord#` y#)
+ | otherwise = divZeroError "mod{Word}" x
+ quotRem x@(W# x#) y@(W# y#)
+ | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word}" x
+ divMod x@(W# x#) y@(W# y#)
+ | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))
+ | otherwise = divZeroError "divMod{Word}" x
+ 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
+#if WORD_SIZE_IN_BYTES == 4
+ maxBound = 0xFFFFFFFF
+#else
+ maxBound = 0xFFFFFFFFFFFFFFFF
+#endif
+
+instance Ix Word where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Word"
+ 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
+ (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#)
+#if WORD_SIZE_IN_BYTES == 4
+ (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (32# -# i'#)))
+ where
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 31#)
+#else
+ (W# x#) `rotate` (I# i#) = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (64# -# i'#)))
+ where
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
+#endif
+ bitSize _ = WORD_SIZE_IN_BYTES * 8
+ 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)
+
+instance CCallable Word8
+instance CReturnable Word8
+
+instance Show Word8 where
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+
+instance Num Word8 where
+ (W8# x#) + (W8# y#) = W8# (wordToWord8# (x# `plusWord#` y#))
+ (W8# x#) - (W8# y#) = W8# (wordToWord8# (x# `minusWord#` y#))
+ (W8# x#) * (W8# y#) = W8# (wordToWord8# (x# `timesWord#` y#))
+ negate (W8# x#) = W8# (wordToWord8# (int2Word# (negateInt# (word2Int# x#))))
+ abs x = x
+ signum 0 = 0
+ signum _ = 1
+ fromInteger (S# i#) = W8# (wordToWord8# (int2Word# i#))
+ fromInteger (J# s# d#) = W8# (wordToWord8# (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 "quot{Word8}" x
+ rem x@(W8# x#) y@(W8# y#)
+ | y /= 0 = W8# (x# `remWord#` y#)
+ | otherwise = divZeroError "rem{Word8}" x
+ div x@(W8# x#) y@(W8# y#)
+ | y /= 0 = W8# (x# `quotWord#` y#)
+ | otherwise = divZeroError "div{Word8}" x
+ mod x@(W8# x#) y@(W8# y#)
+ | y /= 0 = W8# (x# `remWord#` y#)
+ | otherwise = divZeroError "mod{Word8}" x
+ quotRem x@(W8# x#) y@(W8# y#)
+ | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word8}" x
+ divMod x@(W8# x#) y@(W8# y#)
+ | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word8}" x
+ toInteger (W8# x#) = S# (word2Int# x#)
+
+instance Bounded Word8 where
+ minBound = 0
+ maxBound = 0xFF
+
+instance Ix Word8 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Word8"
+ 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
+ (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# (wordToWord8# (x# `shiftL#` i#))
+ | otherwise = W8# (x# `shiftRL#` negateInt# i#)
+ (W8# x#) `rotate` (I# i#) = W8# (wordToWord8# ((x# `shiftL#` i'#) `or#`
+ (x# `shiftRL#` (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# (wordToWord8# 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)
+
+instance CCallable Word16
+instance CReturnable Word16
+
+instance Show Word16 where
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+
+instance Num Word16 where
+ (W16# x#) + (W16# y#) = W16# (wordToWord16# (x# `plusWord#` y#))
+ (W16# x#) - (W16# y#) = W16# (wordToWord16# (x# `minusWord#` y#))
+ (W16# x#) * (W16# y#) = W16# (wordToWord16# (x# `timesWord#` y#))
+ negate (W16# x#) = W16# (wordToWord16# (int2Word# (negateInt# (word2Int# x#))))
+ abs x = x
+ signum 0 = 0
+ signum _ = 1
+ fromInteger (S# i#) = W16# (wordToWord16# (int2Word# i#))
+ fromInteger (J# s# d#) = W16# (wordToWord16# (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 "quot{Word16}" x
+ rem x@(W16# x#) y@(W16# y#)
+ | y /= 0 = W16# (x# `remWord#` y#)
+ | otherwise = divZeroError "rem{Word16}" x
+ div x@(W16# x#) y@(W16# y#)
+ | y /= 0 = W16# (x# `quotWord#` y#)
+ | otherwise = divZeroError "div{Word16}" x
+ mod x@(W16# x#) y@(W16# y#)
+ | y /= 0 = W16# (x# `remWord#` y#)
+ | otherwise = divZeroError "mod{Word16}" x
+ quotRem x@(W16# x#) y@(W16# y#)
+ | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word16}" x
+ divMod x@(W16# x#) y@(W16# y#)
+ | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word16}" x
+ toInteger (W16# x#) = S# (word2Int# x#)
+
+instance Bounded Word16 where
+ minBound = 0
+ maxBound = 0xFFFF
+
+instance Ix Word16 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Word16"
+ 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
+ (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# (wordToWord16# (x# `shiftL#` i#))
+ | otherwise = W16# (x# `shiftRL#` negateInt# i#)
+ (W16# x#) `rotate` (I# i#) = W16# (wordToWord16# ((x# `shiftL#` i'#) `or#`
+ (x# `shiftRL#` (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# (wordToWord16# x#)
+"fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#)
+ #-}
+
+------------------------------------------------------------------------
+-- type Word32
+------------------------------------------------------------------------
+
+-- Word32 is represented in the same way as Word.
+#if WORD_SIZE_IN_BYTES == 8
+-- Operations may assume and must ensure that it holds only values
+-- from its logical range.
+#endif
+
+data Word32 = W32# Word# deriving (Eq, Ord)
+
+instance CCallable Word32
+instance CReturnable Word32
+
+instance Show Word32 where
+#if WORD_SIZE_IN_BYTES == 4
+ showsPrec p x = showsPrec p (toInteger x)
+#else
+ showsPrec p x = showsPrec p (fromIntegral x :: Int)
+#endif
+
+instance Num Word32 where
+ (W32# x#) + (W32# y#) = W32# (wordToWord32# (x# `plusWord#` y#))
+ (W32# x#) - (W32# y#) = W32# (wordToWord32# (x# `minusWord#` y#))
+ (W32# x#) * (W32# y#) = W32# (wordToWord32# (x# `timesWord#` y#))
+ negate (W32# x#) = W32# (wordToWord32# (int2Word# (negateInt# (word2Int# x#))))
+ abs x = x
+ signum 0 = 0
+ signum _ = 1
+ fromInteger (S# i#) = W32# (wordToWord32# (int2Word# i#))
+ fromInteger (J# s# d#) = W32# (wordToWord32# (integer2Word# s# d#))
+
+instance Real Word32 where
+ toRational x = toInteger x % 1
+
+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_BYTES == 8
+ && i <= fromIntegral (maxBound::Word32)
+#endif
+ = W32# (int2Word# i#)
+ | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32)
+#if WORD_SIZE_IN_BYTES == 4
+ 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 "quot{Word32}" x
+ rem x@(W32# x#) y@(W32# y#)
+ | y /= 0 = W32# (x# `remWord#` y#)
+ | otherwise = divZeroError "rem{Word32}" x
+ div x@(W32# x#) y@(W32# y#)
+ | y /= 0 = W32# (x# `quotWord#` y#)
+ | otherwise = divZeroError "div{Word32}" x
+ mod x@(W32# x#) y@(W32# y#)
+ | y /= 0 = W32# (x# `remWord#` y#)
+ | otherwise = divZeroError "mod{Word32}" x
+ quotRem x@(W32# x#) y@(W32# y#)
+ | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word32}" x
+ divMod x@(W32# x#) y@(W32# y#)
+ | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word32}" x
+ toInteger (W32# x#)
+#if WORD_SIZE_IN_BYTES == 4
+ | i# >=# 0# = S# i#
+ | otherwise = case word2Integer# x# of (# s, d #) -> J# s d
+ where
+ i# = word2Int# x#
+#else
+ = S# (word2Int# x#)
+#endif
+
+instance Bounded Word32 where
+ minBound = 0
+ maxBound = 0xFFFFFFFF
+
+instance Ix Word32 where
+ range (m,n) = [m..n]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Word32"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Read Word32 where
+#if WORD_SIZE_IN_BYTES == 4
+ 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
+
+instance Bits Word32 where
+ (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# (wordToWord32# (x# `shiftL#` i#))
+ | otherwise = W32# (x# `shiftRL#` negateInt# i#)
+ (W32# x#) `rotate` (I# i#) = W32# (wordToWord32# ((x# `shiftL#` i'#) `or#`
+ (x# `shiftRL#` (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# (wordToWord32# x#)
+"fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#)
+ #-}
+
+------------------------------------------------------------------------
+-- type Word64
+------------------------------------------------------------------------
+
+#if WORD_SIZE_IN_BYTES == 4
+
+data Word64 = W64# Word64#
+
+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 "quot{Word64}" x
+ rem x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `remWord64#` y#)
+ | otherwise = divZeroError "rem{Word64}" x
+ div x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `quotWord64#` y#)
+ | otherwise = divZeroError "div{Word64}" x
+ mod x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `remWord64#` y#)
+ | otherwise = divZeroError "mod{Word64}" x
+ quotRem x@(W64# x#) y@(W64# y#)
+ | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
+ | otherwise = divZeroError "quotRem{Word64}" x
+ divMod x@(W64# x#) y@(W64# y#)
+ | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#))
+ | otherwise = divZeroError "quotRem{Word64}" x
+ toInteger x@(W64# x#)
+ | x <= 0x7FFFFFFF = S# (word2Int# (word64ToWord# x#))
+ | otherwise = case word64ToInteger# x# of (# s, d #) -> J# s d
+
+instance Bits Word64 where
+ (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#) = W64# ((x# `shiftL64#` i'#) `or64#`
+ (x# `shiftRL64#` (64# -# i'#)))
+ where
+ i'# = word2Int# (int2Word# i# `and#` int2Word# 63#)
+ bitSize _ = 64
+ isSigned _ = False
+
+foreign import "stg_eqWord64" unsafe eqWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_neWord64" unsafe neWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_ltWord64" unsafe ltWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_leWord64" unsafe leWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_gtWord64" unsafe gtWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_geWord64" unsafe geWord64# :: Word64# -> Word64# -> Bool
+foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64#
+foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64#
+foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64#
+foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64#
+foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64#
+foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word#
+foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_not64" unsafe not64# :: Word64# -> Word64#
+foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> 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
+
+data Word64 = W64# Word# deriving (Eq, Ord)
+
+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 "quot{Word64}" x
+ rem x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `remWord#` y#)
+ | otherwise = divZeroError "rem{Word64}" x
+ div x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `quotWord#` y#)
+ | otherwise = divZeroError "div{Word64}" x
+ mod x@(W64# x#) y@(W64# y#)
+ | y /= 0 = W64# (x# `remWord#` y#)
+ | otherwise = divZeroError "mod{Word64}" x
+ quotRem x@(W64# x#) y@(W64# y#)
+ | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word64}" x
+ divMod x@(W64# x#) y@(W64# y#)
+ | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#))
+ | otherwise = divZeroError "quotRem{Word64}" x
+ 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
+ (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#) = W64# ((x# `shiftL#` i'#) `or#`
+ (x# `shiftRL#` (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 CCallable Word64
+instance CReturnable Word64
+
+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]
+ index b@(m,_) i
+ | inRange b i = fromIntegral (i - m)
+ | otherwise = indexError b i "Word64"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Read Word64 where
+ readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
+\end{code}
--- /dev/null
+---------------------------------------------------------------------------
+-- Main.hi
+--
+-- This hand-written interface file fakes a "Main" module
+-- It is used *solely* so that GHCmain generates the right kind of
+-- external reference to Main.main
+---------------------------------------------------------------------------
+
+__interface Main 1 where
+__export Main main ;
+1 main :: __forall a => GHCziIOBase.IO a; -- wish this could be __o. KSW 1999-04.
+
+
--- /dev/null
+# -----------------------------------------------------------------------------
+# $Id: Makefile,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+ifeq "$(way)" ""
+SUBDIRS = cbits
+else
+SUBDIRS=
+endif
+
+ALL_DIRS = \
+ Control \
+ Control/Concurrent \
+ Control/Monad \
+ Control/Monad/ST \
+ Data \
+ Data/Array \
+ Database \
+ Debug \
+ FileFormat \
+ Foreign \
+ Foreign/C \
+ Foreign/Marshal \
+ GHC \
+ Hugs \
+ Language \
+ Network \
+ NHC \
+ System \
+ System/IO \
+ Text \
+ Text/Show
+
+PRE_SRCS += $(wildcard $(patsubst %, %/*.hsc, $(ALL_DIRS)))
+SRC_HSC2HS_OPTS += -Iinclude -I.
+
+ALL_HS_SRCS = $(wildcard $(patsubst %, %/*.hs, . $(ALL_DIRS)))
+ALL_LHS_SRCS += $(wildcard GHC/*.lhs)
+ALL_HS_OBJS = $(patsubst %.hs, %.o, $(ALL_HS_SRCS)) \
+ $(patsubst %.lhs, %.o, $(ALL_LHS_SRCS))
+
+
+srcs : $(HS_SRCS) GHC/Prim.$(way_)hi
+
+# dependencies between .hsc files
+GHC/IO.hs : GHC/Handle.hs
+
+GHC/Prim.$(way_)hi : GHC/Prim.hi-boot
+ cp $< $@
+
+SRC_HC_OPTS += -cpp -fglasgow-exts -fvia-C -I$(FPTOOLS_TOP)/ghc/includes -Iinclude -package-name std -H128m $(GhcLibHcOpts)
+
+LIBNAME = libHScore$(_way).a
+
+CLEAN_FILES += $(ALL_HS_OBJS)
+
+all :: $(LIBNAME)
+
+lib : srcs
+ $(GHC_INPLACE) $(HC_OPTS) --make $(ALL_HS_SRCS) $(ALL_LHS_SRCS)
+
+$(LIBNAME) : lib
+ $(RM) $@
+ $(AR) $(AR_OPTS) $@ $(ALL_HS_OBJS)
+ $(RANLIB) $@
+
+%.o : %.hs
+ $(GHC_INPLACE) $(HC_OPTS) --make $<
+%.o : %.lhs
+ $(GHC_INPLACE) $(HC_OPTS) --make $<
+
+include $(TOP)/mk/target.mk
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Prelude
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Prelude.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+--
+-- Standard module imported by default into Haskell modules.
+--
+-----------------------------------------------------------------------------
+
+module Prelude (
+
+ -- List things
+ [] (..),
+
+ map, (++), filter, concat,
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, 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,
+ maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3,
+
+ lines, words, unlines, unwords,
+ sum, product,
+
+ -- Everything from Text.Read and Text.Show
+ ReadS, ShowS,
+ Read(readsPrec, readList),
+ Show(showsPrec, showList, show),
+ reads, shows, read, lex,
+ showChar, showString, readParen, showParen,
+
+ -- Everything corresponding to the Report's PreludeIO
+ ioError, userError, catch,
+ FilePath, IOError,
+ putChar,
+ putStr, putStrLn, print,
+ getChar,
+ getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn,
+
+ Bool(..),
+ Maybe(..),
+ Either(..),
+ Ordering(..),
+ Char, String, Int, Integer, Float, Double, IO,
+ Rational,
+ []((:), []),
+
+ module GHC.Tup,
+ -- Includes tuple types + fst, snd, curry, uncurry
+ ()(..), -- The unit type
+ (->), -- functions
+
+ Eq(..),
+ Ord(..),
+ Enum(..),
+ Bounded(..),
+ Num(..),
+ Real(..),
+ Integral(..),
+ Fractional(..),
+ Floating(..),
+ RealFrac(..),
+ RealFloat(..),
+
+ -- Monad stuff, from GHC.Base, and defined here
+ Monad(..),
+ Functor(..),
+ mapM, mapM_, sequence, sequence_, (=<<),
+
+ maybe, either,
+ (&&), (||), not, otherwise,
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, realToFrac,
+ --exported by GHC.Tup: fst, snd, curry, uncurry,
+ id, const, (.), flip, ($), until,
+ asTypeOf, error, undefined,
+ seq, ($!)
+
+ ) where
+
+import Control.Monad
+import System.IO
+import Text.Read
+import Text.Show
+import Data.List
+import Data.Either
+import Data.Maybe
+import Data.Bool
+
+#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.Tup
+import GHC.Show
+import GHC.Conc
+import GHC.Err ( error, undefined )
+#endif
+
+infixr 0 $!
+
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous functions
+
+($!) :: (a -> b) -> a -> b
+f $! x = x `seq` f x
+
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.CPUTime
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: CPUTime.hsc,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- The standard CPUTime library.
+--
+-----------------------------------------------------------------------------
+
+module System.CPUTime
+ (
+ getCPUTime, -- :: IO Integer
+ cpuTimePrecision -- ::Â Integer
+ ) where
+
+import Prelude
+
+import Foreign
+import Foreign.C
+
+import Data.Ratio
+
+#include "HsCore.h"
+
+-- -----------------------------------------------------------------------------
+-- Computation `getCPUTime' returns the number of picoseconds CPU time
+-- used by the current program. The precision of this result is
+-- implementation-dependent.
+
+-- 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.
+
+getCPUTime :: IO Integer
+getCPUTime = do
+
+#ifndef _WIN32
+-- 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_TARGET_OS && ! solaris2_TARGET_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 CLong
+ u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CLong
+ s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CLong
+ s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CLong
+
+ return ((fromIntegral u_sec * 1000000 + fromIntegral u_usec +
+ fromIntegral s_sec * 1000000 + fromIntegral s_usec)
+ * 1000000)
+
+type CRUsage = ()
+foreign import 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
+ return (( (fromIntegral u_ticks + fromIntegral s_ticks) * 1000000000000)
+ `div` clockTicks)
+
+type CTms = ()
+foreign import unsafe times :: Ptr CTms -> CClock
+# else
+ ioException (IOError Nothing UnsupportedOperation
+ "getCPUTime"
+ "can't get CPU time"
+ Nothing)
+# endif
+#endif
+
+#else /* _WIN32 */
+ 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 <- ft2usecs p_userTime
+ kt <- ft2usecs p_kernelTime
+ return (fromIntegral (ut + kt))
+ else return 0
+ where ft2usecs ft = do
+ high <- (#peek FILETIME,dwHighDateTime) ft :: IO CLong
+ low <- (#peek FILETIME,dwLowDateTime) ft :: IO CLong
+ return (high * (2^32) + low)
+
+ -- 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 "GetCurrentProcess" unsafe getCurrentProcess :: IO (Ptr HANDLE)
+foreign import "GetProcessTimes" unsafe getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt
+
+#endif /* not _WIN32 */
+
+cpuTimePrecision :: Integer
+cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks))
+
+clockTicks :: Int
+clockTicks =
+#if defined(CLK_TCK)
+ (#const CLK_TCK)
+#else
+ unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral)
+foreign import unsafe sysconf :: CInt -> IO CLong
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Cmd
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Cmd.hsc,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Executing a command.
+--
+-----------------------------------------------------------------------------
+
+module System.Cmd
+ ( system -- :: String -> IO ExitCode
+ ) where
+
+import Prelude
+
+import System.Exit
+import Foreign.C
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+#endif
+
+#include "HsCore.h"
+
+-- ---------------------------------------------------------------------------
+-- 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.
+
+system :: String -> IO ExitCode
+system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
+system cmd =
+ withUnsafeCString cmd $ \s -> do
+ status <- throwErrnoIfMinus1 "system" (primSystem s)
+ case status of
+ 0 -> return ExitSuccess
+ n -> return (ExitFailure n)
+
+foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Environment
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Environment.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Miscellaneous information about the system environment.
+--
+-----------------------------------------------------------------------------
+
+module System.Environment
+ (
+ , getArgs -- :: IO [String]
+ , getProgName -- :: IO String
+ , getEnv -- :: String -> IO String
+ ) where
+
+import Prelude
+
+import Foreign
+import Foreign.C
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+#endif
+
+-- ---------------------------------------------------------------------------
+-- getArgs, getProgName, getEnv
+
+-- Computation `getArgs' returns a list of the program's command
+-- line arguments (not including the program name).
+
+getArgs :: IO [String]
+getArgs = do
+ argv <- peek prog_argv_label
+ argc <- peek prog_argc_label
+ peekArray (fromIntegral argc - 1) (advancePtr argv 1) >>= mapM peekCString
+
+foreign label "prog_argv" prog_argv_label :: Ptr (Ptr (Ptr CChar))
+foreign label "prog_argc" prog_argc_label :: Ptr CInt
+
+-- Computation `getProgName' returns the name of the program
+-- as it was invoked.
+
+getProgName :: IO String
+getProgName = do
+ argv <- peek prog_argv_label
+ unpackProgName argv
+
+unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
+unpackProgName argv = do
+ s <- peekElemOff argv 0 >>= peekCString
+ return (de_slash "" s)
+ where
+ -- re-start accumulating at every '/'
+ de_slash :: String -> String -> String
+ de_slash acc [] = reverse acc
+ de_slash _acc ('/':xs) = de_slash [] xs
+ de_slash acc (x:xs) = de_slash (x:acc) xs
+
+-- Computation `getEnv var' returns the value
+-- of the environment variable {\em var}.
+
+-- This computation may fail with
+-- NoSuchThing: The environment variable does not exist.
+
+getEnv :: String -> IO String
+getEnv name =
+ withUnsafeCString 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 "getenv" unsafe
+ c_getenv :: UnsafeCString -> IO (Ptr CChar)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Exit
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Exit.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- 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
+
+-- ---------------------------------------------------------------------------
+-- exitWith
+
+-- `exitWith code' terminates the program, returning `code' to the
+-- program's caller. Before it terminates, any open or semi-closed
+-- handles are first closed.
+
+exitWith :: ExitCode -> IO a
+exitWith ExitSuccess = throw (ExitException ExitSuccess)
+exitWith code@(ExitFailure n)
+ | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing)
+ | otherwise = throw (ExitException code)
+
+exitFailure :: IO a
+exitFailure = exitWith (ExitFailure 1)
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : System.IO
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: IO.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- The standard IO library.
+--
+-----------------------------------------------------------------------------
+
+module System.IO (
+ Handle, -- abstract, instance of: Eq, Show.
+ HandlePosn(..), -- abstract, instance of: Eq, Show.
+
+ IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
+ BufferMode(NoBuffering,LineBuffering,BlockBuffering),
+ SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
+
+ stdin, stdout, stderr, -- :: Handle
+
+ 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
+ hReady, -- :: Handle -> 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, -- :: Show a => Handle -> a -> IO ()
+ hIsOpen, hIsClosed, -- :: Handle -> IO Bool
+ hIsReadable, hIsWritable, -- :: Handle -> IO Bool
+ hIsSeekable, -- :: Handle -> IO Bool
+
+ isAlreadyExistsError, isDoesNotExistError, -- :: IOError -> Bool
+ isAlreadyInUseError, isFullError,
+ isEOFError, isIllegalOperation,
+ isPermissionError, isUserError,
+
+ ioeGetErrorString, -- :: IOError -> String
+ ioeGetHandle, -- :: IOError -> Maybe Handle
+ ioeGetFileName, -- :: IOError -> Maybe FilePath
+
+ try, -- :: IO a -> IO (Either IOError a)
+ bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+ bracket_, -- :: IO a -> (a -> IO b) -> IO c -> IO c
+
+ -- Non-standard extension (but will hopefully become standard with 1.5) is
+ -- to export the Prelude io functions via IO (in addition to exporting them
+ -- from the prelude...for now.)
+ IO,
+ FilePath, -- :: String
+ IOError,
+ ioError, -- :: IOError -> IO a
+ userError, -- :: String -> IOError
+ catch, -- :: IO a -> (IOError -> IO a) -> IO a
+ 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
+ readFile, -- :: FilePath -> IO String
+ writeFile, -- :: FilePath -> String -> IO ()
+ appendFile, -- :: FilePath -> String -> IO ()
+ readIO, -- :: Read a => String -> IO a
+ readLn, -- :: Read a => IO a
+
+ hPutBuf, -- :: Handle -> Ptr a -> Int -> IO ()
+ hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int
+
+ fixIO, -- :: (a -> IO a) -> IO a
+ ) 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.ST ( fixST )
+import GHC.Exception
+import GHC.Num
+import GHC.Read
+import GHC.Show
+#endif
+
+import Data.Dynamic
+
+-- -----------------------------------------------------------------------------
+-- Typeable instance for Handle
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+
+-- -----------------------------------------------------------------------------
+-- Standard IO
+
+putChar :: Char -> IO ()
+putChar c = hPutChar stdout c
+
+putStr :: String -> IO ()
+putStr s = hPutStr stdout s
+
+putStrLn :: String -> IO ()
+putStrLn s = do putStr s
+ putChar '\n'
+
+print :: Show a => a -> IO ()
+print x = putStrLn (show x)
+
+getChar :: IO Char
+getChar = hGetChar stdin
+
+getLine :: IO String
+getLine = hGetLine stdin
+
+getContents :: IO String
+getContents = hGetContents stdin
+
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+readFile :: FilePath -> IO String
+readFile name = openFile name ReadMode >>= hGetContents
+
+writeFile :: FilePath -> String -> IO ()
+writeFile name str = do
+ hdl <- openFile name WriteMode
+ hPutStr hdl str
+ hClose hdl
+
+appendFile :: FilePath -> String -> IO ()
+appendFile name str = do
+ hdl <- openFile name AppendMode
+ hPutStr hdl str
+ hClose hdl
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+-- raises an exception instead of an error
+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")
+
+hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn hndl str = do
+ hPutStr hndl str
+ hPutChar hndl '\n'
+
+hPrint :: Show a => Handle -> a -> IO ()
+hPrint hdl = hPutStrLn hdl . show
+
+-- ---------------------------------------------------------------------------
+-- fixIO
+
+#ifdef __GLASGOW_HASKELL__
+fixIO :: (a -> IO a) -> IO a
+fixIO m = stToIO (fixST (ioToST . m))
+#endif
--- /dev/null
+-- -----------------------------------------------------------------------------
+-- $Id: Directory.hsc,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2000
+--
+
+-- The Directory Interface
+
+{-
+A directory contains a series of entries, each of which is a named
+reference to a file system object (file, directory etc.). Some
+entries may be hidden, inaccessible, or have some administrative
+function (e.g. "." or ".." under POSIX), but in this standard all such
+entries are considered to form part of the directory contents.
+Entries in sub-directories are not, however, considered to form part
+of the directory contents.
+
+Each file system object is referenced by a {\em path}. There is
+normally at least one absolute path to each file system object. In
+some operating systems, it may also be possible to have paths which
+are relative to the current directory.
+-}
+
+module System.IO.Directory
+ (
+ Permissions -- abstract
+
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
+
+ , createDirectory -- :: FilePath -> IO ()
+ , removeDirectory -- :: FilePath -> IO ()
+ , renameDirectory -- :: FilePath -> FilePath -> IO ()
+
+ , getDirectoryContents -- :: FilePath -> IO [FilePath]
+ , getCurrentDirectory -- :: IO FilePath
+ , setCurrentDirectory -- :: FilePath -> IO ()
+
+ , removeFile -- :: FilePath -> IO ()
+ , renameFile -- :: FilePath -> FilePath -> IO ()
+
+ , doesFileExist -- :: FilePath -> IO Bool
+ , doesDirectoryExist -- :: FilePath -> IO Bool
+
+ , getPermissions -- :: FilePath -> IO Permissions
+ , setPermissions -- :: FilePath -> Permissions -> IO ()
+
+ , getModificationTime -- :: FilePath -> IO ClockTime
+ ) where
+
+import Prelude
+
+import System.Time ( ClockTime(..) )
+import System.IO
+import Foreign
+import Foreign.C
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Posix
+import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
+#endif
+
+-- to get config.h
+#include "HsCore.h"
+
+#include <sys/stat.h>
+#include <dirent.h>
+#include <limits.h>
+#include <errno.h>
+#include <unistd.h>
+
+-----------------------------------------------------------------------------
+-- Permissions
+
+-- The Permissions type is used to record whether certain
+-- operations are permissible on a file/directory:
+-- [to whom? - presumably the "current user"]
+
+data Permissions
+ = Permissions {
+ readable, writable,
+ executable, searchable :: Bool
+ } deriving (Eq, Ord, Read, Show)
+
+-----------------------------------------------------------------------------
+-- Implementation
+
+-- `createDirectory dir' creates a new directory dir which is
+-- initially empty, or as near to empty as the operating system
+-- allows.
+
+-- The operation may fail with:
+
+{-
+\begin{itemize}
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EROFS, EACCES]@
+\item @isAlreadyExistsError@ / @AlreadyExists@
+The operand refers to a directory that already exists.
+@ [EEXIST]@
+\item @HardwareFault@
+A physical I/O error has occurred.
+@ [EIO]@
+\item @InvalidArgument@
+The operand is not a valid directory name.
+@[ENAMETOOLONG, ELOOP]@
+\item @NoSuchThing@
+There is no path to the directory.
+@[ENOENT, ENOTDIR]@
+\item @ResourceExhausted@
+Insufficient resources (virtual memory, process file descriptors,
+physical disk space, etc.) are available to perform the operation.
+@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
+\item @InappropriateType@
+The path refers to an existing non-directory object.
+@[EEXIST]@
+\end{itemize}
+-}
+
+createDirectory :: FilePath -> IO ()
+createDirectory path = do
+ withUnsafeCString path $ \s -> do
+ throwErrnoIfMinus1Retry_ "createDirectory" $
+#if defined(mingw32_TARGET_OS)
+ mkdir s
+#else
+ mkdir s 0o777
+#endif
+
+{-
+@removeDirectory dir@ removes an existing directory {\em dir}. The
+implementation may specify additional constraints which must be
+satisfied before a directory can be removed (e.g. the directory has to
+be empty, or may not be in use by other processes). It is not legal
+for an implementation to partially remove a directory unless the
+entire directory is removed. A conformant implementation need not
+support directory removal in all situations (e.g. removal of the root
+directory).
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+[@EIO@]
+\item @InvalidArgument@
+The operand is not a valid directory name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExist@ / @NoSuchThing@
+The directory does not exist.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EROFS, EACCES, EPERM]@
+\item @UnsatisfiedConstraints@
+Implementation-dependent constraints are not satisfied.
+@[EBUSY, ENOTEMPTY, EEXIST]@
+\item @UnsupportedOperation@
+The implementation does not support removal in this situation.
+@[EINVAL]@
+\item @InappropriateType@
+The operand refers to an existing non-directory object.
+@[ENOTDIR]@
+\end{itemize}
+-}
+
+removeDirectory :: FilePath -> IO ()
+removeDirectory path = do
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeDirectory" (rmdir s)
+
+{-
+@Removefile file@ removes the directory entry for an existing file
+{\em file}, where {\em file} is not itself a directory. The
+implementation may specify additional constraints which must be
+satisfied before a file can be removed (e.g. the file may not be in
+use by other processes).
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @InvalidArgument@
+The operand is not a valid file name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExist@ / @NoSuchThing@
+The file does not exist.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EROFS, EACCES, EPERM]@
+\item @UnsatisfiedConstraints@
+Implementation-dependent constraints are not satisfied.
+@[EBUSY]@
+\item @InappropriateType@
+The operand refers to an existing directory.
+@[EPERM, EINVAL]@
+\end{itemize}
+-}
+
+removeFile :: FilePath -> IO ()
+removeFile path = do
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeFile" (unlink s)
+
+{-
+@renameDirectory@ {\em old} {\em new} changes the name of an existing
+directory from {\em old} to {\em new}. If the {\em new} directory
+already exists, it is atomically replaced by the {\em old} directory.
+If the {\em new} directory is neither the {\em old} directory nor an
+alias of the {\em old} directory, it is removed as if by
+$removeDirectory$. A conformant implementation need not support
+renaming directories in all situations (e.g. renaming to an existing
+directory, or across different physical devices), but the constraints
+must be documented.
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @InvalidArgument@
+Either operand is not a valid directory name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExistError@ / @NoSuchThing@
+The original directory does not exist, or there is no path to the target.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EROFS, EACCES, EPERM]@
+\item @ResourceExhausted@
+Insufficient resources are available to perform the operation.
+@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
+\item @UnsatisfiedConstraints@
+Implementation-dependent constraints are not satisfied.
+@[EBUSY, ENOTEMPTY, EEXIST]@
+\item @UnsupportedOperation@
+The implementation does not support renaming in this situation.
+@[EINVAL, EXDEV]@
+\item @InappropriateType@
+Either path refers to an existing non-directory object.
+@[ENOTDIR, EISDIR]@
+\end{itemize}
+-}
+
+renameDirectory :: FilePath -> FilePath -> IO ()
+renameDirectory opath npath =
+ withFileStatus opath $ \st -> do
+ is_dir <- isDirectory st
+ if (not is_dir)
+ then ioException (IOError Nothing InappropriateType "renameDirectory"
+ ("not a directory") (Just opath))
+ else do
+
+ withUnsafeCString opath $ \s1 ->
+ withUnsafeCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameDirectory" (rename s1 s2)
+
+{-
+@renameFile@ {\em old} {\em new} changes the name of an existing file system
+object from {\em old} to {\em new}. If the {\em new} object already
+exists, it is atomically replaced by the {\em old} object. Neither
+path may refer to an existing directory. A conformant implementation
+need not support renaming files in all situations (e.g. renaming
+across different physical devices), but the constraints must be
+documented.
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @InvalidArgument@
+Either operand is not a valid file name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExistError@ / @NoSuchThing@
+The original file does not exist, or there is no path to the target.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EROFS, EACCES, EPERM]@
+\item @ResourceExhausted@
+Insufficient resources are available to perform the operation.
+@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
+\item @UnsatisfiedConstraints@
+Implementation-dependent constraints are not satisfied.
+@[EBUSY]@
+\item @UnsupportedOperation@
+The implementation does not support renaming in this situation.
+@[EXDEV]@
+\item @InappropriateType@
+Either path refers to an existing directory.
+@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@
+\end{itemize}
+-}
+
+renameFile :: FilePath -> FilePath -> IO ()
+renameFile opath npath =
+ withFileStatus opath $ \st -> do
+ is_dir <- isDirectory st
+ if is_dir
+ then ioException (IOError Nothing InappropriateType "renameFile"
+ "is a directory" (Just opath))
+ else do
+
+ withUnsafeCString opath $ \s1 ->
+ withUnsafeCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameFile" (rename s1 s2)
+
+{-
+@getDirectoryContents dir@ returns a list of {\em all} entries
+in {\em dir}.
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @InvalidArgument@
+The operand is not a valid directory name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExistError@ / @NoSuchThing@
+The directory does not exist.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EACCES]@
+\item @ResourceExhausted@
+Insufficient resources are available to perform the operation.
+@[EMFILE, ENFILE]@
+\item @InappropriateType@
+The path refers to an existing non-directory object.
+@[ENOTDIR]@
+\end{itemize}
+-}
+
+getDirectoryContents :: FilePath -> IO [FilePath]
+getDirectoryContents path = do
+ p <- withUnsafeCString path $ \s ->
+ throwErrnoIfNullRetry "getDirectoryContents" (opendir s)
+ loop p
+ where
+ loop :: Ptr CDir -> IO [String]
+ loop dir = do
+ resetErrno
+ p <- readdir dir
+ if (p /= nullPtr)
+ then do
+#ifdef mingw32_TARGET_OS
+ entryp <- (#peek struct dirent,d_name) p
+ entry <- peekCString entryp -- on mingwin it's a char *, not a char []
+#else
+ entry <- peekCString ((#ptr struct dirent,d_name) p)
+#endif
+ entries <- loop dir
+ return (entry:entries)
+ else do errno <- getErrno
+ if (errno == eINTR) then loop dir else do
+ throwErrnoIfMinus1_ "getDirectoryContents" $ closedir dir
+#ifdef mingw32_TARGET_OS
+ if (errno == eNOENT) -- mingwin (20001111) cunningly sets errno to ENOENT when it runs out of files
+#else
+ if (errno == eOK)
+#endif
+ then return []
+ else throwErrno "getDirectoryContents"
+
+{-
+If the operating system has a notion of current directories,
+@getCurrentDirectory@ returns an absolute path to the
+current directory of the calling process.
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @isDoesNotExistError@ / @NoSuchThing@
+There is no path referring to the current directory.
+@[EPERM, ENOENT, ESTALE...]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EACCES]@
+\item @ResourceExhausted@
+Insufficient resources are available to perform the operation.
+\item @UnsupportedOperation@
+The operating system has no notion of current directory.
+\end{itemize}
+-}
+
+getCurrentDirectory :: IO FilePath
+getCurrentDirectory = do
+ p <- mallocBytes (#const PATH_MAX)
+ go p (#const PATH_MAX)
+ where go p bytes = do
+ p' <- getcwd p (fromIntegral bytes)
+ if p' /= nullPtr
+ then do s <- peekCString p'
+ free p'
+ return s
+ else do errno <- getErrno
+ if errno == eRANGE
+ then do let bytes' = bytes * 2
+ p' <- reallocBytes p bytes'
+ go p' bytes'
+ else throwErrno "getCurrentDirectory"
+
+{-
+If the operating system has a notion of current directories,
+@setCurrentDirectory dir@ changes the current
+directory of the calling process to {\em dir}.
+
+The operation may fail with:
+\begin{itemize}
+\item @HardwareFault@
+A physical I/O error has occurred.
+@[EIO]@
+\item @InvalidArgument@
+The operand is not a valid directory name.
+@[ENAMETOOLONG, ELOOP]@
+\item @isDoesNotExistError@ / @NoSuchThing@
+The directory does not exist.
+@[ENOENT, ENOTDIR]@
+\item @isPermissionError@ / @PermissionDenied@
+The process has insufficient privileges to perform the operation.
+@[EACCES]@
+\item @UnsupportedOperation@
+The operating system has no notion of current directory, or the
+current directory cannot be dynamically changed.
+\item @InappropriateType@
+The path refers to an existing non-directory object.
+@[ENOTDIR]@
+\end{itemize}
+-}
+
+setCurrentDirectory :: FilePath -> IO ()
+setCurrentDirectory path = do
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s)
+ -- ToDo: add path to error
+
+{-
+To clarify, @doesDirectoryExist@ returns True if a file system object
+exist, and it's a directory. @doesFileExist@ returns True if the file
+system object exist, but it's not a directory (i.e., for every other
+file system object that is not a directory.)
+-}
+
+doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name =
+ catch
+ (withFileStatus name $ \st -> isDirectory st)
+ (\ _ -> return False)
+
+doesFileExist :: FilePath -> IO Bool
+doesFileExist name = do
+ catch
+ (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
+ (\ _ -> return False)
+
+getModificationTime :: FilePath -> IO ClockTime
+getModificationTime name =
+ withFileStatus name $ \ st ->
+ modificationTime st
+
+getPermissions :: FilePath -> IO Permissions
+getPermissions name = do
+ withUnsafeCString name $ \s -> do
+ read <- access s (#const R_OK)
+ write <- access s (#const W_OK)
+ exec <- access s (#const X_OK)
+ withFileStatus name $ \st -> do
+ is_dir <- isDirectory st
+ is_reg <- isRegularFile st
+ return (
+ Permissions {
+ readable = read == 0,
+ writable = write == 0,
+ executable = not is_dir && exec == 0,
+ searchable = not is_reg && exec == 0
+ }
+ )
+
+setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions name (Permissions r w e s) = do
+ let
+ read = if r then (#const S_IRUSR) else emptyCMode
+ write = if w then (#const S_IWUSR) else emptyCMode
+ exec = if e || s then (#const S_IXUSR) else emptyCMode
+
+ mode = read `unionCMode` (write `unionCMode` exec)
+
+ withUnsafeCString name $ \s ->
+ throwErrnoIfMinus1_ "setPermissions" $ chmod s mode
+
+withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus name f = do
+ allocaBytes (#const sizeof(struct stat)) $ \p ->
+ withUnsafeCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ "withFileStatus" (stat s p)
+ f p
+
+modificationTime :: Ptr CStat -> IO ClockTime
+modificationTime stat = do
+ mtime <- (#peek struct stat, st_mtime) stat
+ return (TOD (toInteger (mtime :: CTime)) 0)
+
+isDirectory :: Ptr CStat -> IO Bool
+isDirectory stat = do
+ mode <- (#peek struct stat, st_mode) stat
+ return (s_ISDIR mode /= 0)
+
+isRegularFile :: Ptr CStat -> IO Bool
+isRegularFile stat = do
+ mode <- (#peek struct stat, st_mode) stat
+ return (s_ISREG mode /= 0)
+
+foreign import ccall unsafe s_ISDIR :: CMode -> Int
+#def inline HsInt s_ISDIR(m) {return S_ISDIR(m);}
+
+foreign import ccall unsafe s_ISREG :: CMode -> Int
+#def inline HsInt s_ISREG(m) {return S_ISREG(m);}
+
+emptyCMode :: CMode
+emptyCMode = 0
+
+unionCMode :: CMode -> CMode -> CMode
+unionCMode = (+)
+
+type UCString = UnsafeCString
+
+#if defined(mingw32_TARGET_OS)
+foreign import ccall unsafe mkdir :: UCString -> IO CInt
+#else
+foreign import ccall unsafe mkdir :: UCString -> CInt -> IO CInt
+#endif
+
+foreign import ccall unsafe chmod :: UCString -> CMode -> IO CInt
+foreign import ccall unsafe access :: UCString -> CMode -> IO CInt
+foreign import ccall unsafe rmdir :: UCString -> IO CInt
+foreign import ccall unsafe chdir :: UCString -> IO CInt
+foreign import ccall unsafe getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar)
+foreign import ccall unsafe unlink :: UCString -> IO CInt
+foreign import ccall unsafe rename :: UCString -> UCString -> IO CInt
+
+foreign import ccall unsafe opendir :: UCString -> IO (Ptr CDir)
+foreign import ccall unsafe readdir :: Ptr CDir -> IO (Ptr CDirent)
+foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt
+
+foreign import ccall unsafe stat :: UCString -> Ptr CStat -> IO CInt
+
+type CDirent = ()
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.IO.Unsafe
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Unsafe.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- "Unsafe" IO operations.
+--
+-----------------------------------------------------------------------------
+
+module System.IO.Unsafe (
+ unsafePerformIO, -- :: IO a -> a
+ unsafeInterleaveIO, -- :: IO a -> IO a
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.IOBase
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Info
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Info.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Misc information about the characteristics of the host
+-- architecture/machine lucky enough to run your program.
+--
+-----------------------------------------------------------------------------
+
+#include "MachDeps.h"
+
+module System.Info
+ (
+ os, -- :: String
+ arch -- :: String
+ ) where
+
+import Prelude
+
+arch :: String
+arch = HOST_ARCH
+
+os :: String
+os = HOST_OS
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Locale
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Locale.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Operations for defining locale-specific date and time formats.
+--
+-----------------------------------------------------------------------------
+
+module System.Locale
+ ( TimeLocale(..)
+ , defaultTimeLocale
+
+ , iso8601DateFormat
+ , rfc822DateFormat
+ )
+where
+
+import Prelude
+
+data TimeLocale = TimeLocale {
+ wDays :: [(String, String)], -- full and abbreviated week days
+ months :: [(String, String)], -- full and abbreviated months
+ intervals :: [(String, String)],
+ amPm :: (String, String), -- AM/PM symbols
+ dateTimeFmt, dateFmt, -- formatting strings
+ 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"
+ }
+
+
+iso8601DateFormat :: Maybe String -> String
+iso8601DateFormat timeFmt =
+ "%Y-%m-%d" ++ case timeFmt of
+ Nothing -> "" -- normally, ISO-8601 just defines YYYY-MM-DD
+ Just fmt -> ' ' : fmt -- but we can add a time spec
+
+
+rfc822DateFormat :: String
+rfc822DateFormat = "%a, %_d %b %Y %H:%M:%S %Z"
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Mem.StableName
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: StableName.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Giving an object a stable (GC-invariant) name.
+--
+-----------------------------------------------------------------------------
+
+module System.Mem.StableName
+ ( StableName {-a-} -- abstract, instance of Eq
+ , makeStableName -- :: a -> IO (StableName a)
+ , hashStableName -- :: StableName a -> Int
+ ) where
+
+import Prelude
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base ( Int(..) )
+import GHC.IOBase ( IO(..) )
+import GHC.Prim ( StableName#, makeStableName#
+ , eqStableName#, stableNameToInt# )
+
+-----------------------------------------------------------------------------
+-- Stable Names
+
+data StableName a = StableName (StableName# a)
+
+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
+
+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 "Dynamic.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/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- $Id: Weak.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Weak references, weak pairs, weak pointers, and finalizers.
+--
+-----------------------------------------------------------------------------
+
+module System.Mem.Weak (
+ Weak, -- abstract
+ -- instance Eq (Weak v)
+
+ mkWeak, -- :: k -> v -> Maybe (IO ()) -> IO (Weak v)
+ deRefWeak, -- :: Weak v -> IO (Maybe v)
+ finalize, -- :: Weak v -> IO ()
+ -- replaceFinaliser -- :: Weak v -> IO () -> IO ()
+
+ mkWeakPtr, -- :: k -> Maybe (IO ()) -> IO (Weak k)
+ mkWeakPair, -- :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
+ addFinalizer -- :: key -> IO () -> IO ()
+ ) where
+
+import Prelude
+
+#include "Dynamic.h"
+INSTANCE_TYPEABLE0(Weak,weakTc,"Weak")
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Base
+import GHC.IOBase
+import GHC.Weak
+
+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 #)
+
+mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
+mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
+
+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
+#endif
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : System.Random
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Random.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Random numbers.
+--
+-----------------------------------------------------------------------------
+
+module System.Random
+ (
+ RandomGen(next, split)
+ , StdGen
+ , mkStdGen
+ , Random ( random, randomR,
+ randoms, randomRs,
+ randomIO, randomRIO )
+ , getStdRandom
+ , getStdGen
+ , setStdGen
+ , newStdGen
+ ) where
+
+-- The June 1988 (v31 #6) issue of the Communications of the ACM has an
+-- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
+-- Random Number Generators". Here is the Portable Combined Generator of
+-- L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18.
+
+-- Transliterator: Lennart Augustsson
+
+-- sof 1/99 - code brought (kicking and screaming) into the new Random
+-- world..
+
+import Prelude
+
+import System.CPUTime ( getCPUTime )
+import Data.Char ( isSpace, chr, ord )
+import System.IO.Unsafe ( unsafePerformIO )
+import Data.IORef
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Show ( showSignedInt, showSpace )
+import GHC.Read ( readDec )
+import GHC.IOBase ( unsafePerformIO, stToIO )
+import System.Time ( getClockTime, ClockTime(..) )
+#endif
+
+class RandomGen g where
+ next :: g -> (Int, g)
+ split :: g -> (g, g)
+
+
+data StdGen
+ = StdGen Int Int
+
+instance RandomGen StdGen where
+ next = stdNext
+ split = stdSplit
+
+#ifdef __GLASGOW_HASKELL__
+instance Show StdGen where
+ showsPrec p (StdGen s1 s2) =
+ showSignedInt p s1 .
+ showSpace .
+ showSignedInt p s2
+#endif
+
+#ifdef __HUGS__
+instance Show StdGen where
+ showsPrec p (StdGen s1 s2) =
+ showsPrec p s1 .
+ showChar ' ' .
+ showsPrec p s2
+#endif
+
+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)
+
+
+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
+
+
+-- The class definition - see library report for details.
+
+class Random a where
+ -- Minimal complete definition: random and randomR
+ random :: RandomGen g => g -> (a, g)
+ randomR :: RandomGen g => (a,a) -> g -> (a,g)
+
+ randoms :: RandomGen g => g -> [a]
+ randoms g = x : randoms g' where (x,g') = random g
+
+ randomRs :: RandomGen g => (a,a) -> g -> [a]
+ randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
+
+ randomIO :: IO a
+ randomIO = getStdRandom random
+
+ randomRIO :: (a,a) -> IO a
+ randomRIO range = getStdRandom (randomR range)
+
+
+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
+
+#ifdef __GLASGOW_HASKELL__
+mkStdRNG :: Integer -> IO StdGen
+mkStdRNG o = do
+ ct <- getCPUTime
+ (TOD sec _) <- getClockTime
+ return (createStdGen (sec * 12345 + ct + o))
+#endif
+
+#ifdef __HUGS__
+mkStdRNG :: Integer -> IO StdGen
+mkStdRNG o = do
+ ct <- getCPUTime
+ return (createStdGen (ct + o))
+#endif
+
+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)
+
+stdNext :: StdGen -> (Int, StdGen)
+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)
+
+
+setStdGen :: StdGen -> IO ()
+setStdGen sgen = writeIORef theStdGen sgen
+
+getStdGen :: IO StdGen
+getStdGen = readIORef theStdGen
+
+theStdGen :: IORef StdGen
+theStdGen = unsafePerformIO (newIORef (createStdGen 0))
+
+newStdGen :: IO StdGen
+newStdGen = do
+ rng <- getStdGen
+ let (a,b) = split rng
+ setStdGen a
+ return b
+
+getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
+getStdRandom f = do
+ rng <- getStdGen
+ let (v, new_rng) = f rng
+ setStdGen new_rng
+ return v
--- /dev/null
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+-- JRS 010117: we had to say NON_POSIX_SOURCE to get the resulting .hc
+-- to compile on sparc-solaris. Blargh.
+-----------------------------------------------------------------------------
+--
+-- Module : System.Time
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Time.hsc,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- The standard Time library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Haskell 98 Time of Day Library
+------------------------------
+
+The Time library provides 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).
+
+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
+ (
+ Month(..)
+ , Day(..)
+
+ , ClockTime(..) -- non-standard, lib. report gives this as abstract
+ -- instance Eq, Ord
+ -- instance Show (non-standard)
+
+ , getClockTime
+
+ , TimeDiff(..)
+ , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.)
+ , diffClockTimes
+ , addToClockTime
+
+ , normalizeTimeDiff -- non-standard
+ , timeDiffToString -- non-standard
+ , formatTimeDiff -- non-standard
+
+ , CalendarTime(..)
+ , toCalendarTime
+ , toUTCTime
+ , toClockTime
+ , calendarTimeToString
+ , formatCalendarTime
+
+ ) where
+
+#include "HsCore.h"
+
+import Prelude
+
+import Data.Ix
+import System.Locale
+import System.IO.Unsafe
+
+import Foreign
+import Foreign.C
+
+-- One way to partition and give name to chunks of a year and a week:
+
+data Month
+ = January | February | March | April
+ | May | June | July | August
+ | September | October | November | December
+ deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
+
+data Day
+ = Sunday | Monday | Tuesday | Wednesday
+ | Thursday | Friday | Saturday
+ deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
+
+-- @ClockTime@ is an abstract type, used for the internal clock time.
+-- Clock times may be compared, converted to strings, or converted to an
+-- external calendar time @CalendarTime@.
+
+data ClockTime = TOD Integer -- Seconds since 00:00:00 on 1 Jan 1970
+ Integer -- Picoseconds with the specified second
+ 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)))
+
+{-
+@CalendarTime@ is a user-readable and manipulable
+representation of the internal $ClockTime$ type. The
+numeric fields have the following ranges.
+
+\begin{verbatim}
+Value Range Comments
+----- ----- --------
+
+year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate]
+mon 0 .. 11 [Jan = 0, Dec = 11]
+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?]
+wday 0 .. 6 [Sunday = 0, Saturday = 6]
+yday 0 .. 365 [364 in non-Leap years]
+tz -43200 .. 43200 [Variation from UTC in seconds]
+\end{verbatim}
+
+The {\em tzname} field is the name of the time zone. The {\em isdst}
+field indicates whether Daylight Savings Time would be in effect.
+-}
+
+data CalendarTime
+ = CalendarTime {
+ ctYear :: Int,
+ ctMonth :: Month,
+ ctDay :: Int,
+ ctHour :: Int,
+ ctMin :: Int,
+ ctSec :: Int,
+ ctPicosec :: Integer,
+ ctWDay :: Day,
+ ctYDay :: Int,
+ ctTZName :: String,
+ ctTZ :: Int,
+ ctIsDST :: Bool
+ }
+ deriving (Eq,Ord,Read,Show)
+
+-- The @TimeDiff@ type 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)
+
+noTimeDiff :: TimeDiff
+noTimeDiff = TimeDiff 0 0 0 0 0 0 0
+
+-- -----------------------------------------------------------------------------
+-- getClockTime returns the current time in its internal representation.
+
+#if HAVE_GETTIMEOFDAY
+getClockTime = do
+ allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
+ throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
+ sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CLong
+ usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CLong
+ return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000))
+
+#elif HAVE_FTIME
+getClockTime = do
+ 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 (fromIntegral sec) (fromIntegral msec * 1000{-ToDo: correct???-}))
+
+#else /* use POSIX time() */
+getClockTime = do
+ secs <- time nullPtr -- can't fail, according to POSIX
+ return (TOD (fromIntegral 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. diffClockTimes t1 t2 returns
+-- the difference between two clock times t1 and t2 as a TimeDiff.
+
+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
+ cal = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec))
+ -- FIXME! ^^^^
+ new_mon = fromEnum (ctMonth cal) + r_mon
+ (month', yr_diff)
+ | 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 :: 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
+ }
+
+
+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 = tdSec td
+ + 60 * (tdMin td
+ + 60 * (tdHour td
+ + 24 * (tdDay td
+ + 30 * (tdMonth td
+ + 365 * 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 = diffYears
+ , tdMonth = diffMonths
+ , tdDay = diffDays
+ , tdHour = diffHours
+ , tdMin = diffMins
+ , tdSec = diffSecs
+ }
+
+-- -----------------------------------------------------------------------------
+-- 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_TARGET_OS
+# define tzname _tzname
+# endif
+# ifndef mingw32_TARGET_OS
+foreign label tzname :: Ptr (Ptr CChar)
+# else
+foreign import "ghcTimezone" unsafe timezone :: Ptr CLong
+foreign import "ghcTzname" unsafe tzname :: Ptr (Ptr CChar)
+# def inline long *ghcTimezone(void) { return &_timezone; }
+# def inline char **ghcTzname(void) { return _tzname; }
+# 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 defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS)
+#define timezone _timezone
+#endif
+
+# if HAVE_ALTZONE
+foreign label altzone :: Ptr CTime
+foreign label timezone :: Ptr CTime
+gmtoff x = do
+ dst <- (#peek struct tm,tm_isdst) x
+ tz <- if dst then peek altzone else peek timezone
+ return (fromIntegral tz)
+# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone )
+# else /* ! HAVE_ALTZONE */
+-- Assume that DST offset is 1 hour ...
+gmtoff x = do
+ dst <- (#peek struct tm,tm_isdst) x
+ tz <- peek timezone
+ if dst then return (fromIntegral tz - 3600) else return tz
+# endif /* ! HAVE_ALTZONE */
+#endif /* ! HAVE_TM_ZONE */
+
+-- -----------------------------------------------------------------------------
+-- toCalendarTime t converts t to a local time, modified by
+-- the current timezone and daylight savings time settings. toUTCTime
+-- t converts t into UTC time. toClockTime l converts l into the
+-- corresponding internal ClockTime. The wday, yday, tzname, and isdst fields
+-- are ignored.
+
+
+toCalendarTime :: ClockTime -> IO CalendarTime
+toCalendarTime = clockToCalendarTime localtime False
+
+toUTCTime :: ClockTime -> CalendarTime
+toUTCTime = unsafePerformIO . clockToCalendarTime gmtime True
+
+-- ToDo: should be made thread safe, because localtime uses static storage,
+-- or use the localtime_r version.
+clockToCalendarTime :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
+ -> IO CalendarTime
+clockToCalendarTime fun is_utc (TOD secs psec) = do
+ withObject (fromIntegral secs :: CTime) $ \ p_timer -> do
+ p_tm <- fun p_timer -- can't fail, according to POSIX
+ 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))
+
+
+toClockTime :: CalendarTime -> ClockTime
+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 res = fromIntegral t - tz + fromIntegral gmtoff
+ return (TOD (fromIntegral res) 0)
+
+-- -----------------------------------------------------------------------------
+-- Converting time values to strings.
+
+calendarTimeToString :: CalendarTime -> String
+calendarTimeToString = formatCalendarTime defaultTimeLocale "%c"
+
+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)
+ where x' = x `rem` 1000
+
+to12 :: Int -> Int
+to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
+
+-- Useful extensions for formatting TimeDiffs.
+
+timeDiffToString :: TimeDiff -> String
+timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
+
+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
+
+
+-- -----------------------------------------------------------------------------
+-- Foreign time interface (POSIX)
+
+type CTm = () -- struct tm
+
+foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm)
+foreign import unsafe gmtime :: Ptr CTime -> IO (Ptr CTm)
+foreign import unsafe mktime :: Ptr CTm -> IO CTime
+foreign import unsafe time :: Ptr CTime -> IO CTime
+
+#if HAVE_GETTIMEOFDAY
+type CTimeVal = ()
+foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt
+#endif
+
+#if HAVE_FTIME
+type CTimeB = ()
+#ifndef mingw32_TARGET_OS
+foreign import unsafe ftime :: Ptr CTimeB -> IO CInt
+#else
+foreign import unsafe ftime :: Ptr CTimeB -> IO ()
+#endif
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Text.Read
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Read.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Exiting the program.
+--
+-----------------------------------------------------------------------------
+
+module Text.Read (
+ ReadS, -- String -> Maybe (a,String)
+ Read(
+ readsPrec, -- :: Int -> ReadS a
+ readList -- :: ReadS [a]
+ ),
+ reads, -- :: (Read a) => ReadS a
+ read, -- :: (Read a) => String -> a
+ readParen, -- :: Bool -> ReadS a -> ReadS a
+ lex, -- :: ReadS String
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Read
+#endif
--- /dev/null
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Text.Show
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Show.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Exiting the program.
+--
+-----------------------------------------------------------------------------
+
+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
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+import GHC.Show
+#endif
+
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Module : Text.Show.Functions
+-- Copyright : (c) The University of Glasgow 2001
+-- License : BSD-style (see the file libraries/core/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- $Id: Functions.hs,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- Optional instance of Text.Show.Show for functions.
+--
+-----------------------------------------------------------------------------
+
+module Text.Show.Functions where
+
+import Prelude
+
+instance Show (a -> b) where
+ showsPrec _ _ = showString "<function>"
--- /dev/null
+# $Id: Makefile,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+
+TOP = ../../..
+include $(TOP)/mk/boilerplate.mk
+
+HSLIB = core
+IS_CBITS_LIB = YES
+
+SRC_CC_OPTS += -Wall -DCOMPILING_STDLIB -I../include -I../../../ghc/includes -I../../../ghc/rts
+
+ifeq "$(DLLized)" "YES"
+SRC_CC_OPTS += -dynamic
+endif
+
+# -----------------------------------------------------------------------------
+# Installation
+
+INSTALL_DATAS += lockFile.h
+
+include $(TOP)/mk/target.mk
--- /dev/null
+/*
+ * (c) The University of Glasgow, 2000-2001
+ *
+ * $Id: errno.c,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * GHC Error Number Conversion
+ */
+
+#include "HsCore.h"
+
+/* Raw errno */
+
+int *ghcErrno(void) {
+ return &errno;
+}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: inputReady.c,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * hReady Runtime Support
+ */
+
+/* select and supporting types is not */
+#ifndef _AIX
+#define NON_POSIX_SOURCE
+#endif
+
+#include "HsCore.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
+inputReady(int fd, int msecs)
+{
+ int maxfd, ready;
+#ifndef mingw32_TARGET_OS
+ fd_set rfd;
+ struct timeval tv;
+#endif
+
+#ifdef mingw32_TARGET_OS
+ return 1;
+#else
+ FD_ZERO(&rfd);
+ 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;
+
+ while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) {
+ if (errno != EINTR ) {
+ return -1;
+ }
+ }
+
+ /* 1 => Input ready, 0 => not ready, -1 => error */
+ return (ready);
+
+#endif
+}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: lockFile.c,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * stdin/stout/stderr Runtime Support
+ */
+
+#include "HsCore.h"
+
+#ifndef FD_SETSIZE
+#define FD_SETSIZE 256
+#endif
+
+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;
+
+ while (fstat(fd, &sb) < 0) {
+ if (errno != EINTR) {
+#ifndef _WIN32
+ return -1;
+#else
+ /* fstat()ing socket fd's seems to fail with CRT's fstat(),
+ so let's just silently return and hope for the best..
+ */
+ return 0;
+#endif
+ }
+ }
+
+ 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) {
+#ifndef __MINGW32__
+ return -1;
+#else
+ break;
+#endif
+ }
+ }
+ /* 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) {
+#ifndef __MINGW32__
+ return -1;
+#else
+ break;
+#endif
+ }
+ }
+ }
+ /* 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) {
+#ifndef __MINGW32__
+ return -1;
+#else
+ break;
+#endif
+ }
+ }
+ /* 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;
+}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
+ *
+ * $Id: system.c,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * system Runtime Support
+ */
+
+/* The itimer stuff in this module is non-posix */
+#define NON_POSIX_SOURCE
+
+#include "HsCore.h"
+
+#if defined(mingw32_TARGET_OS)
+#include <windows.h>
+#endif
+
+HsInt
+systemCmd(HsAddr cmd)
+{
+#if defined(mingw32_TARGET_OS)
+ STARTUPINFO sInfo;
+ PROCESS_INFORMATION pInfo;
+ DWORD retCode;
+
+ sInfo.cb = sizeof(STARTUPINFO);
+ sInfo.lpReserved = NULL;
+ sInfo.lpReserved2 = NULL;
+ sInfo.cbReserved2 = 0;
+ sInfo.lpDesktop = NULL;
+ sInfo.lpTitle = NULL;
+ sInfo.dwFlags = 0;
+
+ if (!CreateProcess(NULL, cmd, NULL, NULL, FALSE, 0, NULL, NULL, &sInfo, &pInfo))
+ return -1;
+ WaitForSingleObject(pInfo.hProcess, INFINITE);
+ if (GetExitCodeProcess(pInfo.hProcess, &retCode) == 0) return -1;
+ CloseHandle(pInfo.hProcess);
+ CloseHandle(pInfo.hThread);
+ return retCode;
+#else
+ int pid;
+ int wstat;
+
+ switch(pid = fork()) {
+ case -1:
+ if (errno != EINTR) {
+ return -1;
+ }
+ case 0:
+ {
+#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
+
+ /* the child */
+ execl("/bin/sh", "sh", "-c", cmd, NULL);
+ _exit(127);
+ }
+ }
+
+ while (waitpid(pid, &wstat, 0) < 0) {
+ if (errno != EINTR) {
+ return -1;
+ }
+ }
+
+ if (WIFEXITED(wstat))
+ return WEXITSTATUS(wstat);
+ else if (WIFSIGNALED(wstat)) {
+ errno = EINTR;
+ }
+ else {
+ /* This should never happen */
+ }
+ return -1;
+#endif
+}
--- /dev/null
+/*
+ * (c) The GRASP/AQUA Project, Glasgow University, 1998
+ *
+ * $Id: writeError.c,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * hPutStr Runtime Support
+ */
+
+/*
+Writing out error messages. This is done outside Haskell
+(i.e., no use of the IO implementation is made), since it
+might be in an unstable state (e.g., hClose stderr >> error "foo")
+
+(A secondary reason is that ``error'' is used by the IO
+implementation in one or two places.)
+
+*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "HsCore.h"
+
+HsAddr
+addrOf_ErrorHdrHook(void)
+{
+ return &ErrorHdrHook;
+}
+
+void
+writeErrString__ (HsAddr msg_hdr, HsAddr msg, HsInt len)
+{
+ int count = 0;
+ char* p = (char*)msg;
+ char nl = '\n';
+
+ resetNonBlockingFd(2);
+
+ /* Print error msg header */
+ if (msg_hdr) {
+ ((void (*)(int))msg_hdr)(2/*stderr*/);
+ }
+
+ while ( (count = write(2,p,len)) < len) {
+ if (errno != EINTR ) {
+ return;
+ }
+ len -= count;
+ p += count;
+ }
+ write(2, &nl, 1);
+}
--- /dev/null
+<!DOCTYPE ARTICLE PUBLIC "-//OASIS//DTD DocBook V3.1//EN">
+
+<article id="libraries">
+ <artheader>
+ <title>Haskell Libraries</title>
+ <orgname>The Haskell Libraries Mailing List</orgname>
+ <address><email>libraries@haskell.org</email></address>
+ </artheader>
+
+ <sect1 id="introduction">
+ <title>Introduction</title>
+
+ <para>This document consistutes part of a proposal for an
+ extension to the <ulink
+ url="http://www.haskell.org/onlinereport/">Haskell 98</ulink>
+ language. The full proposal has several parts: </para>
+
+ <itemizedlist>
+ <listitem>
+ <para>A modest language extension to Haskell 98 that adds the
+ character <quote>.</quote> to the lexical syntax for a module
+ name, allowing a hierarchical module namespace where a module
+ name is a sequence of components separated by periods.</para>
+ </listitem>
+ <listitem>
+ <para>An allocation of the new module namespace to existing
+ and non-existent libraries, people, organisations, and local
+ use.</para>
+ </listitem>
+ <listitem>
+ <para>A policy and procedure for allocating new parts of the
+ namespace.</para>
+ </listitem>
+ <listitem>
+ <para>A set of libraries which are under the control of the
+ community, have reference implementations kept in a standard
+ place, and conform to a set of guidelines and policies set out
+ in this document. We shall call this set of libraries the
+ <firstterm>core libraries</firstterm>.</para>
+ </listitem>
+ </itemizedlist>
+
+ <para>In addition, this document also describes:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>Guidelines and conventions for organising the
+ hierarchy.</para>
+ </listitem>
+ <listitem>
+ <para>Our policy with respect to the design and evolution of
+ library APIs, versioning of library APIs, and maintenance of
+ the reference implementation.</para>
+ </listitem>
+ <listitem>
+ <para>A set of conventions for coding style and portability
+ within the core libraries.</para>
+ </listitem>
+ </itemizedlist>
+ </sect1>
+
+ <sect1 id="contributing">
+ <title>How to contribute</title>
+
+ <para>This project is driven by the Haskell community, so
+ contributions of all kinds are welcome. The first step is to join
+ the <ulink
+ url="http://www.haskell.org/mailman/listinfo/libraries">Haskell
+ libraries mailing list</ulink>, and maybe <ulink
+ url="http://www.haskell.org/pipermail/libraries/">browse the list
+ archives</ulink>. Some of the ways you can contribute are:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>By donating code: for libraries in the core set which
+ don't yet have a reference implementation, or for new
+ contributions to the core set, code is always welcome. Code
+ that conforms to the style guidelines (which aren't very
+ strict, see <xref linkend="conventions">) and comes with
+ documentation (<xref linkend="documentation">) and a test
+ suite (<xref linkend="testing">) is better, but these aren't
+ essential. As a library progresses through the stability
+ scale (<xref linkend="stability">) these things become more
+ important, but for an experimental library we're not going to
+ worry too much about this stuff.</para>
+ </listitem>
+ <listitem>
+ <para>By porting code for an existing library to a new
+ compiler or architecture. A library is classed as portable if
+ it should be available regardless of which compiler/platform
+ combination you're using; however, many libraries are
+ non-portable for one reason or another (see <xref
+ linkend="portability">, and broadening the scope of these
+ libraries is always welcome.</para>
+ </listitem>
+ <listitem>
+ <para>Become a library maintainer: if you have a particular
+ interest in and/or knowledge about a certain library, and have
+ the time to spare, and the library in question doesn't already
+ have a maintainer, then you may be a suitable maintainer for
+ the library. The responsibilities of library maintainers are
+ given in <xref linkend="maintainership">. </para>
+ </listitem>
+ <listitem>
+ <para>Participating in the design process for new libraries,
+ and suggesting improvements to existing libraries. Everyone
+ on the <ulink
+ url="http://www.haskell.org/mailman/listinfo/libraries">Haskell
+ libraries mailing list</ulink> is invited to
+ participate in the design process, so get involved!</para>
+ </listitem>
+ </itemizedlist>
+ </sect1>
+
+ <sect1 id="layout">
+ <title>The hierarchy layout</title>
+
+ <para>We first classify each node in the hierarchy according to
+ one of the following terms:</para>
+
+ <variablelist>
+ <varlistentry>
+ <term>Allocated</term>
+ <listitem>
+ <para>Nodes in the hierarchy can be allocated to a library
+ (whether the library actually exists or not). The currently
+ allocated nodes are specified in <xref
+ linkend="hierarchy">.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>User</term>
+ <listitem>
+ <para>The <literal>User</literal> hierarchy is reserved for
+ users: a user may always use the portion of the hierarchy
+ which is formed from his/her email address as follows:
+ replace the <literal>@</literal> by a <literal>.</literal>,
+ reverse the order of the components, capitalise the first
+ letter of each component, and prepend
+ <literal>User.</literal>. For example,
+ <literal>simonmar@microsoft.com</literal> becomes
+ <literal>User.Com.Microsoft.Simonmar</literal>.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>Organisation</term>
+ <listitem>
+ <para>The <literal>Org</literal> hierarchy is reserved for
+ organisations. Any organisation with a DNS domain name owns
+ a unique space in the hierarchy formed by reversing the
+ components of the domain, capitalising the first character
+ of each component, and prepending
+ <literal>Org.</literal>. <emphasis>ToDo: I don't like this
+ very much, any better ideas?</emphasis></para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>Local</term>
+ <listitem>
+ <para>The <literal>Local</literal> hierarchy is reserved for
+ libraries which are local to the current site. Libraries
+ which are to be distributed outside the current site should
+ not be placed in the <literal>Local</literal>
+ hierarchy.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>Top-level</term>
+ <listitem>
+ <para>All top-level names (i.e. module names that don't
+ contain a <quote><literal>.</literal></quote>) that are
+ otherwise unallocated, are available for use by the program.
+ Note that for compabibility with Haskell 98, some modules in
+ this namespace are reserved
+ (eg. <literal>Directory</literal>, <literal>IO</literal>,
+ <literal>Time</literal> etc.).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>Unallocated</term>
+ <listitem>
+ <para>Any node which doesn't belong to any of the above
+ categories is currently unallocated, and is not available
+ for use.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ <para>A node in the hierarchy may be both a specific library and a
+ parent node for a number of child nodes. For example,
+ <literal>Foreign</literal> is a library, and so is
+ <literal>Foreign.Ptr</literal>.</para>
+
+ <sect2 id="hierarchy-design-guidelines">
+ <title>Hierarchy design guidelines</title>
+ <para></para>
+ </sect2>
+
+ <sect2 id="module-naming-convention">
+ <title>Module Naming Conventions</title>
+ <para></para>
+ </sect2>
+
+ <sect2 id="hierarchy">
+ <title>The hierarchy</title>
+
+ <para>The currently allocated top-level names are:</para>
+
+ <variablelist>
+ <varlistentry>
+ <term><literal>Prelude</literal></term>
+ <listitem>
+ <para>Haskell98 Prelude (mostly just re-exports other
+ parts of the tree).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Control</literal></term>
+ <listitem>
+ <para> Libraries which provide functions, types or classes
+ whose purpose is primarily to express control
+ structure.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Data</literal></term>
+ <listitem>
+ <para>Libraries which provide data types, operations over
+ data types, or type classes, except for libraries for
+ which one of the other more specific categories is
+ appropriate.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Database</literal></term>
+ <listitem>
+ <para>Libraries for providing access to or operations for
+ building databases.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Debug</literal></term>
+ <listitem>
+ <para>Support for debugging Haskell programs.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Edison</literal></term>
+ <listitem>
+ <para>The Edison data structure library.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>FileFormat</literal></term>
+ <listitem>
+ <para>Support for reading and/or writing various file
+ formats (except: programming language source code which
+ lives in <literal>Language</literal>, database formats
+ which live in <literal>Database</literal>, and textual
+ file formats which are catered for in
+ <literal>Text</literal>).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Foreign</literal></term>
+ <listitem>
+ <para>Interaction with code written in a foreign
+ programming language.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Graphics</literal></term>
+ <listitem>
+ <para>Libraries for producing graphics or providing
+ graphical user interfaces.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Language</literal></term>
+ <listitem>
+ <para>Libraries for operating on or generating source code
+ in various programming languages, including parsers,
+ pretty printers, abstract syntax definitions etc.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Local</literal></term>
+ <listitem>
+ <para>Available for site-local use.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Numeric</literal></term>
+ <listitem>
+ <para>Functions and classes which provide operations over
+ numeric data.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Network</literal></term>
+ <listitem>
+ <para>Libraries for communicating over a network,
+ including implementations of network protocols.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Org</literal></term>
+ <listitem>
+ <para>Allocated to organisations on a domain-name
+ basis (see <xref linkend="layout">).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>System</literal></term>
+ <listitem>
+ <para>Libraries for communication with the system on which
+ the Haskell program is running (including the runtime
+ system).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Text</literal></term>
+ <listitem>
+ <para>Libraries for parsing and generating data in a
+ textual format (including structured textual formats such
+ as XML, HTML, but not including programming language
+ source, which lives in Language).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>GHC</literal></term>
+ <listitem>
+ <para>Libraries specific to the GHC/GHCi system.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>NHC</literal></term>
+ <listitem>
+ <para>Libraries specific to the NHC compiler.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>Hugs</literal></term>
+ <listitem>
+ <para>Libraries specific to the Hugs system.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><literal>User</literal></term>
+ <listitem>
+ <para>Allocated to individual users, using email
+ addresses (see <xref linkend="layout">).</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </sect2>
+ </sect1>
+
+ <sect1 id="licensing">
+ <title>Licensing</title>
+
+ <para>Following some discussion on the mailing list related to how
+ we should license the libraries, the viewpoint that was least
+ offensive to all involved seems to be the following:</para>
+
+ <para>We wish to accomodate source code from different
+ contributors, and with different licenses. However, a library of
+ modules where each module is released under a different license,
+ and where the dependencies between modules aren't clear, isn't
+ workable (it's too hard for a user of the library to tell whether
+ they're violating the terms of the each license or not).</para>
+
+ <para>So the solution is as follows: code under different licenses
+ will be clearly separate in the repository (i.e. in separate
+ subdirectories), and compilers are expected to present packages of
+ modules where all modules in a package fall under the same
+ license, and where the dependencies between packages are
+ clear.</para>
+
+ <para>It was decided that certain essential functionality should
+ be available under a BSD style license. Hence, the BSD part of
+ the repository will contain implementations of at least the
+ following modules: <literal>Prelude</literal>,
+ <literal>Foreign</literal>, <emphasis>ToDo: what
+ else?</emphasis>.</para>
+
+ <para><emphasis>ToDo: include a prototype BSD license
+ here</emphasis>.</para>
+ </sect1>
+
+ <sect1 id="versioning">
+ <title>Versioning</title>
+ <para></para>
+ </sect1>
+
+ <sect1 id="stability">
+ <title>Library Stability</title>
+
+ <para>The stability of a library relates primarily to its API.
+ Stability provides an indication of how often the API is likely to
+ change (or whether it may even go away entirely).</para>
+
+ <para>The stability scale is also a measure of how strictly the
+ conventions in this document are applied to the library: an
+ experimental library isn't subject to any restrictions regarding
+ coding style and documentation, but a stable library is expected
+ to adhere to the guidelines, and come with full documentation and
+ tests.</para>
+
+ <para>To help with the stability issue, library maintainers are
+ allowed to mark functions, types or classes as
+ <firstterm>deprecated</firstterm><footnote><para>Compilers may have
+ extra support for warning about the use of a deprecated feature, for
+ example GHC's <literal>DEPRECATED</literal> pragma.</para>
+ </footnote>, which means simply that the
+ feature will be removed at a later date. Just how long it will
+ stick around for depends on the stability category of the library
+ (see below). A feature is marked as deprecated in the
+ documentation for the library, and optionally in an
+ implementation-dependent way which enables the system to warn
+ about the use of deprecated features.</para>
+
+ <para>The current stability categories are:</para>
+
+ <variablelist>
+ <varlistentry>
+ <term><firstterm>experimental</firstterm></term>
+ <listitem>
+ <para>An experimental library is unrestricted in terms of
+ API changes: the API may change between minor revisions and
+ there is no requirement to retain old interfaces for
+ compatibility. Documentation and tests aren't required for
+ an experimental library.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><firstterm>provisional</firstterm></term>
+ <listitem>
+ <para>A provisional library is moving towards stability, and
+ the rate of change of the API is slower. API changes
+ between minor revisions must be accompanied by deprecated
+ versions of the old features where possible. API changes
+ between major versions are unrestricted. The library should
+ come with at least rudimentary documentation.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><firstterm>stable</firstterm></term>
+ <listitem>
+ <para>A stable library has an essentially fixed API.
+ Additions to the API may be made for a minor release,
+ deprecated features must be retained for at least one major
+ revision, and small changes only may be made to the existing
+ API semantics for a major revision. A stable library is
+ expected to include full documentation and tests.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ </sect1>
+
+ <sect1 id="portability">
+ <title>Portability Considerations</title>
+
+ <para>The portability status of a library affects under which
+ platforms and compilers the library will be available on. Haskell
+ implementations are expected to provide all of the portable core
+ libraries, and those non-portable core libraries which are
+ appropriate for that particular platform/compiler
+ implementation.</para>
+
+ <para>The precise meaning of the terms portable and non-portable
+ for our purposes are given below:</para>
+
+ <variablelist>
+ <varlistentry>
+ <term><firstterm>Portable</firstterm></term>
+ <listitem>
+ <para>A portable library may use only Haskell 98 features
+ plus approved extensions (see <xref linkend="portability">),
+ and may not use any platform-specific features. It may make
+ use of other portable libraries only.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><firstterm>Non-portable</firstterm></term>
+ <listitem>
+ <para>A non-portable library may be non-portable for one or
+ more of the following reasons:</para>
+ <variablelist>
+ <varlistentry>
+ <term><firstterm>Requires extensions</firstterm></term>
+ <listitem>
+ <para>A library which uses non-approved language
+ extensions.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><firstterm>Requires nonportable libraries</firstterm></term>
+ <listitem>
+ <para>A library which depends (directly or indirectly)
+ on other non-portable libraries.</para>
+ </listitem>
+ </varlistentry>
+ <varlistentry>
+ <term><firstterm>OS-specific</firstterm></term>
+ <term><firstterm>Platform-specific</firstterm></term>
+ <listitem>
+ <para>A library which depends on features or APIs
+ particular to a certain OS or platform is non-portable
+ for that reason.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ </sect1>
+
+ <sect1 id="maintainership">
+ <title>Library Maintainers</title>
+
+ <para>This is a collaborative project, so we like to devolve
+ control of the design and implementation of libraries to those
+ with an interest or appropriate expertise (or maybe just the
+ time!). A maintainer isn't necessarily a single person - for
+ example, the listed maintainer for most of the core libraries is
+ <email>libraries@haskell.org</email>, indicating that the library
+ is under the control of the community as a whole. The maintainer
+ for the <literal>Foreign</literal> hierarchy is
+ <email>ffi@haskell.org</email>, the mailing list for discussion of
+ the Haskell FFI standard.</para>
+
+ <para>The responsibilities of a library maintainer include:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>Most importantly: act as a single point of contact for
+ issues relating to the library API and its
+ implementation.</para>
+ </listitem>
+ <listitem>
+ <para>Manage any discussion related to the library (which can
+ take place on <email>libraries.haskell.org</email> if
+ necessary), and summarise the results. Make final decisions,
+ and implement them.</para>
+ </listitem>
+ <listitem>
+ <para>Maintain the implementation, including: fixing bugs,
+ updating to keep up with changes in other libraries, porting
+ to new compilers/platforms, and integrating code from other
+ contributors. The maintainer is expected to be the only
+ person/group to make functional changes to the source code
+ (non-functional or trivial changes don't count).</para>
+ </listitem>
+ <listitem>
+ <para>Maintain/write the documentation and tests.</para>
+ </listitem>
+ <listitem>
+ <para>If you can't maintain the library any more for whatever
+ reason, tell <email>libraries@haskell.org</email> and we'll
+ revert the maintainer status of the library to the
+ default.</para>
+ </listitem>
+ </itemizedlist>
+
+ <sect2 id="core-team">
+ <title>The Core Team</title>
+
+ <para>The core team is responsible for making final decisions
+ about the project as a whole and resolving disputes where
+ necessary. We expect that needing to invoke the core team will
+ be a rare occurrence.</para>
+
+ <para>The core team is also responsible for approving
+ maintainership requests.</para>
+
+ <para>Currently, the core team consists of one person from each
+ of the compiler camps, and these are also the people that will
+ primarily be maintaining the library framework for their
+ respective compiler projects:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>Simon Marlow
+ <email>simonmar@microsoft.com</email> (GHC representative)</para>
+ </listitem>
+ <listitem>
+ <para>Malcolm Wallace
+ <email>Malcolm.Wallace@cs.york.ac.uk</email> (NHC representative)</para>
+ </listitem>
+ <listitem>
+ <para>Andy Gill
+ <email>andy@galconn.com</email> (Hugs representative)</para>
+ </listitem>
+ </itemizedlist>
+ </sect2>
+
+ </sect1>
+
+ <sect1 id="documentation">
+ <title>Documentation</title>
+ <para></para>
+ </sect1>
+
+ <sect1 id="testing">
+ <title>Testing</title>
+ <para></para>
+ </sect1>
+
+ <sect1 id="Migration-path">
+ <title>Migration path</title>
+
+ <para>How compatible will a compiler using the new libraries be
+ with code written for Haskell 98 or older library systems (such as
+ the <literal>hslibs</literal> suite and GHC's package system), and
+ for how long will compatibility be maintained?</para>
+
+ <para>Our current plan for GHC is as follows: by default, with the
+ <option>-fglasgow-exts</option> flag, you'll get access to the
+ core libraries. Compatibility with Haskell 98 code will be
+ maintained using a separate package of wrappers presenting
+ interfaces for the Haskell 98 libraries (<literal>IO</literal>,
+ <literal>Ratio</literal>, <literal>Directory</literal>, etc.).
+ The Haskell 98 compatibility package will be enabled by default,
+ but we plan to add an option to disable it if necessary. For code
+ that uses <literal>-package lang</literal>, we could also provide
+ a compatibility wrapper package (so <literal>-package
+ lang</literal> will continue to work as before and present the
+ same library interfaces), but this may prove too much work to
+ maintain - we haven't decided whether to do this or not. It is
+ unlikely that compatibility wrappers for any of the other
+ <literal>hslibs</literal> packages will be provided.</para>
+ </sect1>
+
+ <sect1 id="conventions">
+ <title>Programming Conventions</title>
+
+ <sect2 id="module-header">
+ <title>Standard Module Header</title> <para>The following module
+ header will be used for all core libraries, and we recommend
+ using it for library source code in general:</para>
+
+<programlisting>
+-----------------------------------------------------------------------------
+--
+-- Module : <replaceable>module</replaceable>
+-- Copyright : (c) <replaceable>author</replaceable> <replaceable>year</replaceable>
+-- License : <replaceable>license</replaceable>
+--
+-- Maintainer : libraries@haskell.org | <replaceable>email-address</replaceable>
+-- Stability : experimental | provisional | stable
+-- Portability : portable | non-portable (<replaceable>reason(s)</replaceable>)
+--
+-- $Id: libraries.sgml,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+--
+-- <replaceable>Description</replaceable>
+-----------------------------------------------------------------------------
+</programlisting>
+
+ <para>where:</para>
+
+ <variablelist>
+ <varlistentry>
+ <term><literal>$Id: libraries.sgml,v 1.1 2001/06/28 14:15:04 simonmar Exp $</literal></term>
+ <listitem>
+ <para>is optional, but usually included if the module is
+ under CVS or RCS control.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>module</replaceable></term>
+ <listitem>
+ <para>is the fully qualified module name of the
+ module</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>author</replaceable>/<replaceable>year</replaceable></term>
+ <listitem>
+ <para>Is the primary author and copyright holder of the
+ module, and the year in which copyright is claimed.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>license</replaceable></term>
+ <listitem>
+ <para>Specifies the license on the file (see <xref
+ linkend="licensing">).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>email-address</replaceable></term>
+ <listitem>
+ <para>The email address of the maintainer, or maintainers,
+ of the library (see <xref linkend="maintainership">).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>reason(s)</replaceable></term>
+ <listitem>
+ <para>The reasons for non-portability must be listed (see
+ <xref linkend="portability">).</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term><replaceable>description</replaceable></term>
+ <listitem>
+ <para>A short description of the module.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ </sect2>
+
+ <sect2 id="naming-conventions">
+ <title>Naming Conventions</title>
+
+ <para>These naming conventions are pulled straight from the
+ <literal>hslibs</literal> documentation. They were formed after
+ lengthy discussions and are heavily based on an initial
+ suggestion from Marcin Kowalczyk
+ <email>qrczak@knm.org.pl</email>.</para>
+
+ <para>Note that the conventions are not mutually exclusive,
+ e.g. should the function creating a set from a list of elements
+ have the name <Literal>set</Literal> or
+ <Literal>listToSet</Literal>? (Alas, it currently has neither
+ name.)</para>
+
+ <para> The following nomenclature is used: Pure,
+ i.e. non-monadic functions are simply called, well,
+ <emphasis>functions</emphasis>. Monadic functions,
+ i.e. functions having a type <Literal>... -> m a</Literal>
+ for some Monad <Literal>m</Literal> are called
+ <emphasis>actions</emphasis>.</para>
+
+ <sect3 id="sec-library-module-names">
+ <title>Module names</title>
+ <itemizedlist>
+ <listitem>
+ <para>A module defining a data type or type class
+ <replaceable>X</replaceable> has the itself the name
+ <replaceable>X</replaceable>, e.g.
+ <literal>StablePtr</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para>A module which re-exports the modules in a subtree
+ of the hierarchy has the same name as the root of that
+ subtree, eg. <literal>Foreign</literal> re-exports
+ <literal>Foreign.Ptr</literal>,
+ <literal>Foreign.MarshalUtils</literal> etc.</para>
+ </listitem>
+
+ <listitem>
+ <para>If a subtree of the hierarchy contains several
+ modules which provide similar functionality (eg. there are
+ several pretty-printing libraries under
+ <literal>Text.PrettyPrinter</literal>), then the module at
+ the root of the subtree generally re-exports just
+ <emphasis>one</emphasis> of the modules in the subtree
+ (possibly the most popular or commonly-used
+ alternative).</para>
+ </listitem>
+
+ <listitem>
+ <para>In Haskell you sometimes publish
+ <emphasis>two</emphasis> interfaces to your libraries; one
+ for users, and one for library writers or advanced users
+ who might want to extend things. Typically the advanced
+ users need to be able to see past certain
+ abstractions.</para>
+
+ <para>The current proposal is for a module named
+ <literal>M</literal>, the <quote>advanced</quote> version
+ would be named <literal>M.Internals</literal>. eg.</para>
+
+<programlisting>
+import Text.Html -- The library
+import Text.Html.Internals -- The non-abstract library (for building other libs)
+</programlisting>
+ </listitem>
+
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-constructor-names">
+ <title>Constructor names</title>
+ <indexterm><primary>Constructor names</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para>Empty values of type <replaceable>X</replaceable>
+ have the name <Literal>empty<replaceable>X</replaceable></Literal>,
+ e.g. <literal>emptySet</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para>Actions creating a new empty value of type
+ <replaceable>X</replaceable> have the name
+ <literal>newEmpty<replaceable>X</replaceable></literal>,
+ e.g. <literal>newEmptyMVar</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para>Functions creating an arbitrary value of type
+ <replaceable>X</replaceable> have the name
+ <replaceable>X</replaceable> itself (with the first letter
+ downcased),
+ e.g. <literal>array</literal>. (<emphasis>TODO</emphasis>:
+ This often collides with <literal>xToY</literal>
+ convention, how should this be resolved?)
+ </para>
+ </listitem>
+
+ <listitem>
+ <para>Actions creating new values arbitrary values of type
+ <replaceable>X</replaceable> have the name
+ <literal>new<replaceable>X</replaceable></literal>,
+ e.g. <literal>newIORef</literal>.
+ </para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-accessor-names">
+ <title>Accessor names</title>
+ <indexterm><primary>Accessor names</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para>Functions getting an attribute of a value or a part
+ of it have the name of the attribute itself,
+ e.g. <literal>length</literal>, <literal>bounds</literal>.
+ </para>
+ </listitem>
+
+ <listitem>
+ <para> Actions accessing some kind of reference or state
+ have the name
+ <literal>get<replaceable>X</replaceable></literal>, where
+ <replaceable>X</replaceable> is the type of the contents
+ or the name of the part being accessed,
+ e.g. <literal>getChar</literal>,
+ <literal>getEnv</literal>. An alternative naming scheme is
+ <literal>read<replaceable>Y</replaceable></literal>,
+ where <replaceable>Y</replaceable> is the type of the
+ reference or container, e.g. <literal>readIORef</literal>.
+ </para>
+ </listitem>
+
+ <listitem>
+ <para>Functions or actions getting a value via a
+ pointer-like type <replaceable>X</replaceable> should be
+ named
+ <literal>deRef<replaceable>X</replaceable></literal>,
+ e.g. <literal>deRefStablePtr</literal>,
+ <literal>deRefWeak</literal>.</para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-modifier-names">
+ <title>Modifier names</title>
+ <indexterm><primary>Modifier names</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para>Functions returning a value with attribute
+ <replaceable>X</replaceable> set to a new value should be
+ named
+ <literal>set<replaceable>X</replaceable></literal>. (<emphasis>TODO</emphasis>:
+ Add Examples.)</para>
+ </listitem>
+
+ <listitem>
+ <para> Actions setting some kind of reference or state
+ have the name
+ <literal>put<replaceable>X</replaceable></literal>, where
+ <replaceable>X</replaceable> is the type of the contents
+ or the name of the part being accessed,
+ e.g. <literal>putChar</literal>. An alternative naming
+ scheme is
+ <literal>write<replaceable>Y</replaceable></literal>,
+ where <replaceable>X</replaceable> is the type of the
+ reference or container,
+ e.g. <literal>writeIORef</literal>. </para></listitem>
+
+ <listitem>
+ <para> Actions in the <literal>IO</literal> monad setting
+ some global state <replaceable>X</replaceable> are
+ traditionally named <literal>setX</literal>, too, although
+ <literal>put<replaceable>X</replaceable></literal> would
+ be more appropriate,
+ e.g. <literal>setReadlineName</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para> Actions modifying a container
+ <replaceable>X</replaceable> by a function of type
+ <literal>a -> a</literal> have the name
+ <literal>modify<replaceable>X</replaceable></literal>,
+ e.g. <literal>modifySTRef</literal>.</para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-predicate-names">
+ <title>Predicate names</title>
+ <indexterm><primary>Predicate names</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para>Predicates, both non-monadic and monadic, testing a
+ property <replaceable>X</replaceable> have the name
+ <literal>is<replaceable>X</replaceable></literal>.
+ </para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-naming-conversions">
+ <title>Names for conversions</title>
+ <indexterm><primary>Names for conversions</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para>Functions converting a value of type
+ <replaceable>X</replaceable> to a value of type
+ <replaceable>Y</replaceable> have the name
+ <literal><replaceable>X</replaceable>To<replaceable>Y</replaceable></literal>
+ with all leading uppercase characters of
+ <replaceable>X</replaceable> converted to lower case,
+ e.g. <literal>stToIO</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para>Overloaded conversion functions of type
+ <literal>C a => a -> <replaceable>X</replaceable></literal>
+ have the name
+ <literal>to<replaceable>X</replaceable></literal>,
+ e.g. <literal>toInteger</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para> Overloaded conversion functions of type
+<literal>C a => <replaceable>X</replaceable> -> a</literal>
+ have the name <literal>from<replaceable>X</replaceable></literal>,
+e.g. <literal>fromInteger</literal>.</para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+
+ <sect3 id="sec-library-misc-names">
+ <title>Miscellaneous naming conventions</title>
+ <indexterm><primary>Miscellaneous naming
+ convetions</primary></indexterm>
+
+ <itemizedlist>
+ <listitem>
+ <para> An action that is identical to another one called
+ <replaceable>X</replaceable>, but discards the return
+ value has the name
+ <literal><replaceable>X</replaceable>_</literal>,
+ e.g. <literal>mapM</literal> and <literal>mapM_</literal>.
+ </para>
+ </listitem>
+
+ <listitem>
+ <para>Functions and actions which are potentially
+ dangerous to use and leave some kind of proof obligation
+ to the programmer have the name
+ <literal>unsafe<replaceable>X</replaceable></literal>,
+ e.g. <literal>unsafePerformIO</literal>.
+ </para>
+ </listitem>
+
+ <listitem>
+ <para>There are two conventions for binary and N-ary
+ variants of an associative operation: One convention uses
+ an operator or a short name for the binary operation and a
+ long name for the N-ary variant,
+ e.g. <literal>(+)</literal> and <literal>sum</literal>,
+ <literal>max</literal> and <literal>maximum</literal>. The
+ other convention suffixes the N-ary variant with
+ <literal>Many</literal>. (<emphasis>TODO</emphasis>: Add
+ Examples.)</para>
+ </listitem>
+
+ <listitem>
+ <para>If possible, names are chosen such that either plain
+ application or <literal>arg1 `operation` arg2</literal> is
+ correct English, e.g. <literal>isPrefixOf</literal> is
+ good for use in backquotes.</para>
+ </listitem>
+ </itemizedlist>
+ </sect3>
+ </sect2>
+
+ <sect2 id="sec-library-misc-conventions">
+ <title>Library design conventions</title>
+
+ <itemizedlist>
+ <listitem>
+ <para>Actions setting and modifying a kind of reference or
+ state return <literal>()</literal>, getting the value is
+ separate, e.g. <literal>writeIORef</literal> and
+ <literal>modifyIORef</literal> both return
+ <literal>()</literal>, only <literal>readIORef</literal>
+ returns the value in an <literal>IORef</literal>
+ </para>
+ </listitem>
+
+ <listitem>
+ <para>A function or action taking a some kind of state and
+ returning a pair consisting of a result and a new state, the
+ result is the first element of the pair and the new state is
+ the second, see e.g. <literal>Random</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para>When the type <literal>Either</literal> is used to
+ encode an error condition and a normal result,
+ <literal>Left</literal> is used for the former and
+ <literal>Right</literal> for the latter, see
+ e.g. <literal>MonadEither</literal>.</para>
+ </listitem>
+
+ <listitem>
+ <para> A module corresponding to a class
+ (e.g. <literal>Bits</literal>) contains the class
+ definition, perhaps some auxiliary functions, and all
+ sensible instances for Prelude types, but nothing
+ more. Other modules containing types for which an instance
+ for the class in question makes sense contain the code for
+ the instance itself.</para>
+ </listitem>
+
+ <listitem>
+ <para> Record-like C bit fields or structs have a
+ record-like interface, i.e. pure getting and setting of
+ fields. (<emphasis>TODO</emphasis>: Clarify a little
+ bit. Add examples.)</para>
+ </listitem>
+
+ <listitem>
+ <para> Although the possibility of partial application
+ suggests the type
+
+<literal><replaceable>attr</replaceable> -> <replaceable>object</replaceable> -> <replaceable>object</replaceable></literal>
+
+ for functions setting an attribute or value, infix notation
+ with backquotes implies
+
+<literal><replaceable>object</replaceable> -> <replaceable>attr</replaceable> -> <replaceable>object</replaceable></literal>.
+
+ (<emphasis>TODO</emphasis>: Add Examples.)</para>
+ </listitem>
+ </itemizedlist>
+ </sect2>
+
+ <sect2 id="coding-style">
+ <title>Coding style conventions</title>
+ <para></para>
+ </sect2>
+
+ </sect1>
+
+ <sect1>
+ <title>Changes to standard Haskell 98 libraries</title>
+
+ <para>Some changes have been made to the standard Haskell 98
+ libraries in the new library scheme, both in the names of the
+ modules themselves and in their exported interfaces. Below is a
+ summary of those changes - at this time, the new libraries are
+ marked as provisional and are maintained by
+ <email>libraries@haskell.org</email>, so changes in the interfaces
+ are all up for discussion.</para>
+
+<screen>
+ modules with interface changes
+ ------------------------------
+
+ Array -> Data.Array
+ added instance Typeable (Array ix a)
+
+ Char -> Data.Char
+ no interface changes (should have instance Typeable?)
+
+ Complex -> Data.Complex
+ added instance Typeable (Complex a)
+
+ IO -> System.IO
+ added
+ hPutBuf :: Handle -> Ptr a -> Int -> IO ()
+ hGetBuf :: Handle -> Ptr a -> Int -> IO Int
+ fixIO :: (a -> IO a) -> IO a
+
+ List -> Data.List
+ exports [](..)
+
+ Numeric -> ????
+ not placed in hierarchy yet
+
+ System -> System.Exit, System.Environment, System.Cmd
+ split into three modules
+
+ just renamed, no interface changes:
+ -----------------------------------
+
+ CPUTTime -> System.CPUTime
+ Directory -> System.IO.Directory
+ Ix -> Data.Ix
+ Locale -> System.Locale
+ Monad -> Data.Monad
+ Random -> System.Radom
+ Ratio -> Data.Ratio
+ Time -> System.Time
+</screen>
+ </sect1>
+
+</article>
+
+
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: CTypes.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * Dirty CPP hackery for CTypes/CTypesISO
+ *
+ * (c) The FFI task force, 2000
+ * -------------------------------------------------------------------------- */
+
+#include "MachDeps.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 NUMERIC_TYPE(T,C,S,B) \
+newtype T = T B deriving (Eq, Ord) ; \
+INSTANCE_NUM(T) ; \
+INSTANCE_READ(T) ; \
+INSTANCE_SHOW(T) ; \
+INSTANCE_ENUM(T) ; \
+INSTANCE_TYPEABLE(T,C,S) ;
+
+#define INTEGRAL_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_BOUNDED(T) ; \
+INSTANCE_REAL(T) ; \
+INSTANCE_INTEGRAL(T) ; \
+INSTANCE_BITS(T)
+
+#define FLOATING_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_REAL(T) ; \
+INSTANCE_FRACTIONAL(T) ; \
+INSTANCE_FLOATING(T) ; \
+INSTANCE_REALFRAC(T) ; \
+INSTANCE_REALFLOAT(T)
+
+#define INSTANCE_READ(T) \
+instance Read T where { \
+ readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) }
+
+#define INSTANCE_SHOW(T) \
+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_TYPEABLE(T,C,S) \
+C :: TyCon ; \
+C = mkTyCon S ; \
+instance Typeable T where { \
+ typeOf _ = mkAppTy C [] }
+
+#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) }
+
+#else /* __GLASGOW_HASKELL__ */
+
+/* On GHC, we just cast the type of each method to the underlying
+ * type. This means that GHC only needs to generate the dictionary
+ * for each instance, rather than a new function for each method (the
+ * simplifier currently isn't clever enough to reduce a method that
+ * simply deconstructs a newtype and calls the underlying method into
+ * an indirection to the underlying method, so that's what we're doing
+ * here).
+ */
+
+#define NUMERIC_TYPE(T,C,S,B) \
+newtype T = T B ; \
+INSTANCE_EQ(T,B) ; \
+INSTANCE_ORD(T,B) ; \
+INSTANCE_NUM(T,B) ; \
+INSTANCE_READ(T,B) ; \
+INSTANCE_SHOW(T,B) ; \
+INSTANCE_ENUM(T,B)
+
+#define INTEGRAL_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_BOUNDED(T,B) ; \
+INSTANCE_REAL(T,B) ; \
+INSTANCE_INTEGRAL(T,B) ; \
+INSTANCE_BITS(T,B)
+
+#define FLOATING_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_REAL(T,B) ; \
+INSTANCE_FRACTIONAL(T,B) ; \
+INSTANCE_FLOATING(T,B) ; \
+INSTANCE_REALFRAC(T) ; \
+INSTANCE_REALFLOAT(T,B)
+
+#define INSTANCE_EQ(T,B) \
+instance Eq T where { \
+ (==) = unsafeCoerce# ((==) :: B -> B -> Bool); \
+ (/=) = unsafeCoerce# ((/=) :: B -> B -> Bool); }
+
+#define INSTANCE_ORD(T,B) \
+instance Ord T where { \
+ compare = unsafeCoerce# (compare :: B -> B -> Ordering); \
+ (<) = unsafeCoerce# ((<) :: B -> B -> Bool); \
+ (<=) = unsafeCoerce# ((<=) :: B -> B -> Bool); \
+ (>=) = unsafeCoerce# ((>=) :: B -> B -> Bool); \
+ (>) = unsafeCoerce# ((>) :: B -> B -> Bool); \
+ max = unsafeCoerce# (max :: B -> B -> B); \
+ min = unsafeCoerce# (min :: B -> B -> B); }
+
+#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); }
+
+#define INSTANCE_NUM(T,B) \
+instance Num T where { \
+ (+) = unsafeCoerce# ((+) :: B -> B -> B); \
+ (-) = unsafeCoerce# ((-) :: B -> B -> B); \
+ (*) = unsafeCoerce# ((*) :: B -> B -> B); \
+ negate = unsafeCoerce# (negate :: B -> B); \
+ abs = unsafeCoerce# (abs :: B -> B); \
+ signum = unsafeCoerce# (signum :: B -> B); \
+ fromInteger = unsafeCoerce# (fromInteger :: Integer -> B); }
+
+#define INSTANCE_BOUNDED(T,B) \
+instance Bounded T where { \
+ minBound = T minBound ; \
+ maxBound = T maxBound }
+
+#define INSTANCE_ENUM(T,B) \
+instance Enum T where { \
+ succ = unsafeCoerce# (succ :: B -> B); \
+ pred = unsafeCoerce# (pred :: B -> B); \
+ toEnum = unsafeCoerce# (toEnum :: Int -> B); \
+ fromEnum = unsafeCoerce# (fromEnum :: B -> Int); \
+ enumFrom = unsafeCoerce# (enumFrom :: B -> [B]); \
+ enumFromThen = unsafeCoerce# (enumFromThen :: B -> B -> [B]); \
+ enumFromTo = unsafeCoerce# (enumFromTo :: B -> B -> [B]); \
+ enumFromThenTo = unsafeCoerce# (enumFromThenTo :: B -> B -> B -> [B]);}
+
+#define INSTANCE_REAL(T,B) \
+instance Real T where { \
+ toRational = unsafeCoerce# (toRational :: B -> Rational) }
+
+#define INSTANCE_INTEGRAL(T,B) \
+instance Integral T where { \
+ quot = unsafeCoerce# (quot:: B -> B -> B); \
+ rem = unsafeCoerce# (rem:: B -> B -> B); \
+ div = unsafeCoerce# (div:: B -> B -> B); \
+ mod = unsafeCoerce# (mod:: B -> B -> B); \
+ quotRem = unsafeCoerce# (quotRem:: B -> B -> (B,B)); \
+ divMod = unsafeCoerce# (divMod:: B -> B -> (B,B)); \
+ toInteger = unsafeCoerce# (toInteger:: B -> Integer); }
+
+#define INSTANCE_BITS(T,B) \
+instance Bits T where { \
+ (.&.) = unsafeCoerce# ((.&.) :: B -> B -> B); \
+ (.|.) = unsafeCoerce# ((.|.) :: B -> B -> B); \
+ xor = unsafeCoerce# (xor:: B -> B -> B); \
+ complement = unsafeCoerce# (complement:: B -> B); \
+ shift = unsafeCoerce# (shift:: B -> Int -> B); \
+ rotate = unsafeCoerce# (rotate:: B -> Int -> B); \
+ bit = unsafeCoerce# (bit:: Int -> B); \
+ setBit = unsafeCoerce# (setBit:: B -> Int -> B); \
+ clearBit = unsafeCoerce# (clearBit:: B -> Int -> B); \
+ complementBit = unsafeCoerce# (complementBit:: B -> Int -> B); \
+ testBit = unsafeCoerce# (testBit:: B -> Int -> Bool); \
+ bitSize = unsafeCoerce# (bitSize:: B -> Int); \
+ isSigned = unsafeCoerce# (isSigned:: B -> Bool); }
+
+#define INSTANCE_FRACTIONAL(T,B) \
+instance Fractional T where { \
+ (/) = unsafeCoerce# ((/) :: B -> B -> B); \
+ recip = unsafeCoerce# (recip :: B -> B); \
+ fromRational = unsafeCoerce# (fromRational :: Rational -> B); }
+
+#define INSTANCE_FLOATING(T,B) \
+instance Floating T where { \
+ pi = unsafeCoerce# (pi :: B); \
+ exp = unsafeCoerce# (exp :: B -> B); \
+ log = unsafeCoerce# (log :: B -> B); \
+ sqrt = unsafeCoerce# (sqrt :: B -> B); \
+ (**) = unsafeCoerce# ((**) :: B -> B -> B); \
+ logBase = unsafeCoerce# (logBase :: B -> B -> B); \
+ sin = unsafeCoerce# (sin :: B -> B); \
+ cos = unsafeCoerce# (cos :: B -> B); \
+ tan = unsafeCoerce# (tan :: B -> B); \
+ asin = unsafeCoerce# (asin :: B -> B); \
+ acos = unsafeCoerce# (acos :: B -> B); \
+ atan = unsafeCoerce# (atan :: B -> B); \
+ sinh = unsafeCoerce# (sinh :: B -> B); \
+ cosh = unsafeCoerce# (cosh :: B -> B); \
+ tanh = unsafeCoerce# (tanh :: B -> B); \
+ asinh = unsafeCoerce# (asinh :: B -> B); \
+ acosh = unsafeCoerce# (acosh :: B -> B); \
+ atanh = unsafeCoerce# (atanh :: B -> B); }
+
+/* The coerce trick doesn't work for RealFrac, these methods are
+ * polymorphic and overloaded.
+ */
+#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,B) \
+instance RealFloat T where { \
+ floatRadix = unsafeCoerce# (floatRadix :: B -> Integer); \
+ floatDigits = unsafeCoerce# (floatDigits :: B -> Int); \
+ floatRange = unsafeCoerce# (floatRange :: B -> (Int,Int)); \
+ decodeFloat = unsafeCoerce# (decodeFloat :: B -> (Integer,Int)); \
+ encodeFloat = unsafeCoerce# (encodeFloat :: Integer -> Int -> B); \
+ exponent = unsafeCoerce# (exponent :: B -> Int); \
+ significand = unsafeCoerce# (significand :: B -> B); \
+ scaleFloat = unsafeCoerce# (scaleFloat :: Int -> B -> B); \
+ isNaN = unsafeCoerce# (isNaN :: B -> Bool); \
+ isInfinite = unsafeCoerce# (isInfinite :: B -> Bool); \
+ isDenormalized = unsafeCoerce# (isDenormalized :: B -> Bool); \
+ isNegativeZero = unsafeCoerce# (isNegativeZero :: B -> Bool); \
+ isIEEE = unsafeCoerce# (isIEEE :: B -> Bool); \
+ atan2 = unsafeCoerce# (atan2 :: B -> B -> B); }
+
+#endif /* __GLASGOW_HASKELL__ */
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: Dynamic.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * Macros to help make Typeable instances.
+ * -------------------------------------------------------------------------- */
+
+#define INSTANCE_TYPEABLE0(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable tycon where { typeOf _ = mkAppTy tcname [] }
+
+#define INSTANCE_TYPEABLE1(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance Typeable a => Typeable (tycon a) where { \
+ typeOf x = mkAppTy tcname [typeOf ((undefined :: tycon a -> a) x) ] }
+
+#define INSTANCE_TYPEABLE2(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance (Typeable a, Typeable b) => Typeable (tycon a b) where { \
+ typeOf x = mkAppTy tcname [typeOf ((undefined :: tycon a b -> a) x), \
+ typeOf ((undefined :: tycon a b -> b) x)] }
+
+#define INSTANCE_TYPEABLE3(tycon,tcname,str) \
+tcname = mkTyCon str; \
+instance (Typeable a, Typeable b, Typeable c) => Typeable (tycon a b c) where {\
+ typeOf a = mkAppTy tcname [typeOf ((undefined :: tycon a b c -> a) a), \
+ typeOf ((undefined :: tycon a b c -> b) a), \
+ typeOf ((undefined :: tycon a b c -> c) a)] }
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: HsCore.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * Definitions for package `core' which are visible in Haskell land.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef HSCORE_H
+#define HSCORE_H
+
+#include "config.h"
+
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_SYS_STAT_H
+#include <sys/stat.h>
+#endif
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+#ifdef HAVE_TERMIOS_H
+#include <termios.h>
+#endif
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+#ifdef HAVE_ERRNO_H
+#include <errno.h>
+#endif
+#if defined(HAVE_GETTIMEOFDAY)
+# ifdef HAVE_SYS_TIME_H
+# include <sys/time.h>
+# endif
+#elif defined(HAVE_GETCLOCK)
+# ifdef HAVE_SYS_TIMERS_H
+# define POSIX_4D9 1
+# include <sys/timers.h>
+# endif
+#endif
+#if defined(HAVE_TIME_H)
+# include <time.h>
+#endif
+#ifdef HAVE_SYS_TIMEB_H
+#include <sys/timeb.h>
+#endif
+#ifdef HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+#ifdef HAVE_SYS_TIMES_H
+#include <sys/times.h>
+#endif
+
+#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
+# if defined(HAVE_SYS_RESOURCE_H)
+# include <sys/resource.h>
+# endif
+#endif
+
+#ifdef hpux_TARGET_OS
+#include <sys/syscall.h>
+#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
+#define HAVE_GETRUSAGE
+#endif
+
+/* For System */
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+#ifdef HAVE_VFORK_H
+#include <vfork.h>
+#endif
+
+#include "lockFile.h"
+
+#include "HsFFI.h"
+
+/* in ghc_errno.c */
+int *ghcErrno(void);
+
+/* in system.c */
+HsInt systemCmd(HsAddr cmd);
+
+/* in inputReady.c */
+int inputReady(int fd, int msecs);
+
+/* in progargs.c */
+HsAddr get_prog_argv(void);
+HsInt get_prog_argc();
+
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: PackedString.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * C Definitions for PackedString.hs
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef PACKEDSTRING_H
+#define PACKEDSTRING_H
+
+/* PackedString.c */
+extern StgInt byteArrayHasNUL__ (StgByteArray ba, StgInt len);
+
+#endif
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: ghc_errno.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * (c) The GHC Team 2001
+ *
+ * Haskell-usable version of errno
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef GHCERRNO_H
+#define GHCERRNO_H
+
+int *ghcErrno(void);
+
+#endif
--- /dev/null
+/*
+ * (c) The University of Glasgow 2001
+ *
+ * $Id: lockFile.h,v 1.1 2001/06/28 14:15:04 simonmar Exp $
+ *
+ * lockFile header
+ */
+
+int lockFile(int fd, int for_writing, int exclusive);
+int unlockFile(int fd);
projects / ghc-base.git / commitdiff