diff options
| author | simonmar <unknown> | 2001-06-28 14:15:04 +0000 |
|---|---|---|
| committer | simonmar <unknown> | 2001-06-28 14:15:04 +0000 |
| commit | 4fb94ae5e5d632748fa2e6c35e259eccc5a1a3f4 (patch) | |
| tree | dd5bc589e37efe68e84099180c16359a3acdb06b /libraries | |
| download | haskell-4fb94ae5e5d632748fa2e6c35e259eccc5a1a3f4.tar.gz | |
[project @ 2001-06-28 14:15:04 by simonmar]
First cut of the Haskell Core Libraries
=======================================
NOTE: it's not meant to be a working snapshot. The code is just here
to look at and so the NHC/Hugs guys can start playing around with it.
There is no build system. For GHC, the libraries tree is intended to
be grafted onto an existing fptools/ tree, and the Makefile in
libraries/core is a quick hack for that setup. This won't work at the
moment without the other changes needed in fptools/ghc, which I
haven't committed because they'll cause breakage. However, with the
changes required these sources build a working Prelude and libraries.
The layout mostly follows the one we agreed on, with one or two minor
changes; in particular the Data/Array layout probably isn't final
(there are several choices here).
The document is in libraries/core/doc as promised.
The cbits stuff is just a copy of ghc/lib/std/cbits and has
GHC-specific stuff in it. We should really separate the
compiler-specific C support from any compiler-independent C support
there might be.
Don't pay too much attention to the portability or stability status
indicated in the header of each source file at the moment - I haven't
gone through to make sure they're all consistent and make sense.
I'm using non-literate source outside of GHC/. Hope that's ok with
everyone.
We need to discuss how the build system is going to work...
Diffstat (limited to 'libraries')
128 files changed, 26157 insertions, 0 deletions
diff --git a/libraries/base/Control/Concurrent.hs b/libraries/base/Control/Concurrent.hs new file mode 100644 index 0000000000..033f2cc91c --- /dev/null +++ b/libraries/base/Control/Concurrent.hs @@ -0,0 +1,199 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +-- A common interface to a collection of useful concurrency +-- abstractions. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent + ( module Control.Concurrent.Chan + , module Control.Concurrent.CVar + , module Control.Concurrent.MVar + , module Control.Concurrent.QSem + , module Control.Concurrent.QSemN + , module Control.Concurrent.SampleVar + +#ifdef __HUGS__ + , forkIO -- :: IO () -> IO () +#elif defined(__GLASGOW_HASKELL__) + , ThreadId + + -- Forking and suchlike + , myThreadId -- :: IO ThreadId + , killThread -- :: ThreadId -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () +#endif + , par -- :: a -> b -> b + , seq -- :: a -> b -> b +#ifdef __GLASGOW_HASKELL__ + , fork -- :: a -> b -> b +#endif + , yield -- :: IO () + +#ifdef __GLASGOW_HASKELL__ + , threadDelay -- :: Int -> IO () + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () +#endif + + -- merging of streams + , mergeIO -- :: [a] -> [a] -> IO [a] + , nmergeIO -- :: [[a]] -> IO [a] + ) where + +import Prelude + +import Control.Exception as Exception + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc +import GHC.TopHandler ( reportStackOverflow, reportError ) +import GHC.IOBase ( IO(..) ) +import GHC.IOBase ( unsafePerformIO , unsafeInterleaveIO ) +import GHC.Base ( fork# ) +import GHC.Prim ( Addr#, unsafeCoerce# ) +#endif + +#ifdef __HUGS__ +import IOExts ( unsafeInterleaveIO, unsafePerformIO ) +import ConcBase +#endif + +import Control.Concurrent.MVar +import Control.Concurrent.CVar +import Control.Concurrent.Chan +import Control.Concurrent.QSem +import Control.Concurrent.QSemN +import Control.Concurrent.SampleVar + +#ifdef __GLASGOW_HASKELL__ +infixr 0 `fork` +#endif + +-- Thread Ids, specifically the instances of Eq and Ord for these things. +-- The ThreadId type itself is defined in std/PrelConc.lhs. + +-- Rather than define a new primitve, we use a little helper function +-- cmp_thread in the RTS. + +#ifdef __GLASGOW_HASKELL__ +foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int +-- Returns -1, 0, 1 + +cmpThread :: ThreadId -> ThreadId -> Ordering +cmpThread (ThreadId t1) (ThreadId t2) = + case cmp_thread (unsafeCoerce# t1) (unsafeCoerce# t2) of + -1 -> LT + 0 -> EQ + _ -> GT -- must be 1 + +instance Eq ThreadId where + t1 == t2 = + case t1 `cmpThread` t2 of + EQ -> True + _ -> False + +instance Ord ThreadId where + compare = cmpThread + +forkIO :: IO () -> IO ThreadId +forkIO action = IO $ \ s -> + case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #) + where + action_plus = Exception.catch action childHandler + +childHandler :: Exception -> IO () +childHandler err = Exception.catch (real_handler err) childHandler + +real_handler :: Exception -> IO () +real_handler ex = + case ex of + -- ignore thread GC and killThread exceptions: + BlockedOnDeadMVar -> return () + AsyncException ThreadKilled -> return () + + -- report all others: + AsyncException StackOverflow -> reportStackOverflow False + ErrorCall s -> reportError False s + other -> reportError False (showsPrec 0 other "\n") + +{-# INLINE fork #-} +fork :: a -> b -> b +fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y + +#endif /* __GLASGOW_HASKELL__ */ + + +max_buff_size :: Int +max_buff_size = 1 + +mergeIO :: [a] -> [a] -> IO [a] +nmergeIO :: [[a]] -> IO [a] + +mergeIO ls rs + = newEmptyMVar >>= \ tail_node -> + newMVar tail_node >>= \ tail_list -> + newQSem max_buff_size >>= \ e -> + newMVar 2 >>= \ branches_running -> + let + buff = (tail_list,e) + in + forkIO (suckIO branches_running buff ls) >> + forkIO (suckIO branches_running buff rs) >> + takeMVar tail_node >>= \ val -> + signalQSem e >> + return val + +type Buffer a + = (MVar (MVar [a]), QSem) + +suckIO :: MVar Int -> Buffer a -> [a] -> IO () + +suckIO branches_running buff@(tail_list,e) vs + = case vs of + [] -> takeMVar branches_running >>= \ val -> + if val == 1 then + takeMVar tail_list >>= \ node -> + putMVar node [] >> + putMVar tail_list node + else + putMVar branches_running (val-1) + (x:xs) -> + waitQSem e >> + takeMVar tail_list >>= \ node -> + newEmptyMVar >>= \ next_node -> + unsafeInterleaveIO ( + takeMVar next_node >>= \ y -> + signalQSem e >> + return y) >>= \ next_node_val -> + putMVar node (x:next_node_val) >> + putMVar tail_list next_node >> + suckIO branches_running buff xs + +nmergeIO lss + = let + len = length lss + in + newEmptyMVar >>= \ tail_node -> + newMVar tail_node >>= \ tail_list -> + newQSem max_buff_size >>= \ e -> + newMVar len >>= \ branches_running -> + let + buff = (tail_list,e) + in + mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >> + takeMVar tail_node >>= \ val -> + signalQSem e >> + return val + where + mapIO f xs = sequence (map f xs) diff --git a/libraries/base/Control/Concurrent/CVar.hs b/libraries/base/Control/Concurrent/CVar.hs new file mode 100644 index 0000000000..8e16596088 --- /dev/null +++ b/libraries/base/Control/Concurrent/CVar.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.CVar +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: CVar.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +-- Channel variables are one-element channels. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.CVar + ( -- abstract + CVar + , newCVar -- :: IO (CVar a) + , writeCVar -- :: CVar a -> a -> IO () + , readCVar -- :: CVar a -> IO a + ) where + +import Prelude + +import Control.Concurrent.MVar + +-- @MVars@ provide the basic mechanisms for synchronising access to a +-- shared resource. @CVars@, or channel variables, provide an abstraction +-- that guarantee that the producer is not allowed to run riot, but +-- enforces the interleaved access to the channel variable,i.e., a +-- producer is forced to wait up for a consumer to remove the previous +-- value before it can deposit a new one in the @CVar@. + +data CVar a + = CVar (MVar a) -- prod -> cons + (MVar ()) -- cons -> prod + +newCVar :: IO (CVar a) +newCVar + = newEmptyMVar >>= \ datum -> + newMVar () >>= \ ack -> + return (CVar datum ack) + +writeCVar :: CVar a -> a -> IO () + +writeCVar (CVar datum ack) val + = takeMVar ack >> + putMVar datum val >> + return () + +readCVar :: CVar a -> IO a +readCVar (CVar datum ack) + = takeMVar datum >>= \ val -> + putMVar ack () >> + return val diff --git a/libraries/base/Control/Concurrent/Chan.hs b/libraries/base/Control/Concurrent/Chan.hs new file mode 100644 index 0000000000..29423e1d84 --- /dev/null +++ b/libraries/base/Control/Concurrent/Chan.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.Chan +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Chan.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Standard, unbounded channel abstraction. +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.Chan + ( Chan -- abstract + + -- creator + , newChan -- :: IO (Chan a) + + -- operators + , writeChan -- :: Chan a -> a -> IO () + , readChan -- :: Chan a -> IO a + , dupChan -- :: Chan a -> IO (Chan a) + , unGetChan -- :: Chan a -> a -> IO () + + , isEmptyChan -- :: Chan a -> IO Bool + + -- stream interface + , getChanContents -- :: Chan a -> IO [a] + , writeList2Chan -- :: Chan a -> [a] -> IO () + + ) where + +import Prelude + +import System.IO.Unsafe ( unsafeInterleaveIO ) +import Control.Concurrent.MVar + +-- A channel is represented by two @MVar@s keeping track of the two ends +-- of the channel contents,i.e., the read- and write ends. Empty @MVar@s +-- are used to handle consumers trying to read from an empty channel. + +data Chan a + = Chan (MVar (Stream a)) + (MVar (Stream a)) + +type Stream a = MVar (ChItem a) + +data ChItem a = ChItem a (Stream a) + +-- See the Concurrent Haskell paper for a diagram explaining the +-- how the different channel operations proceed. + +-- @newChan@ sets up the read and write end of a channel by initialising +-- these two @MVar@s with an empty @MVar@. + +newChan :: IO (Chan a) +newChan = do + hole <- newEmptyMVar + read <- newMVar hole + write <- newMVar hole + return (Chan read write) + +-- To put an element on a channel, a new hole at the write end is created. +-- What was previously the empty @MVar@ at the back of the channel is then +-- filled in with a new stream element holding the entered value and the +-- new hole. + +writeChan :: Chan a -> a -> IO () +writeChan (Chan _read write) val = do + new_hole <- newEmptyMVar + modifyMVar_ write $ \old_hole -> do + putMVar old_hole (ChItem val new_hole) + return new_hole + +readChan :: Chan a -> IO a +readChan (Chan read _write) = do + modifyMVar read $ \read_end -> do + (ChItem val new_read_end) <- readMVar read_end + -- Use readMVar here, not takeMVar, + -- else dupChan doesn't work + return (new_read_end, val) + +dupChan :: Chan a -> IO (Chan a) +dupChan (Chan _read write) = do + hole <- readMVar write + new_read <- newMVar hole + return (Chan new_read write) + +unGetChan :: Chan a -> a -> IO () +unGetChan (Chan read _write) val = do + new_read_end <- newEmptyMVar + modifyMVar_ read $ \read_end -> do + putMVar new_read_end (ChItem val read_end) + return new_read_end + +isEmptyChan :: Chan a -> IO Bool +isEmptyChan (Chan read write) = do + withMVar read $ \r -> do + w <- readMVar write + let eq = r == w + eq `seq` return eq + +-- Operators for interfacing with functional streams. + +getChanContents :: Chan a -> IO [a] +getChanContents ch + = unsafeInterleaveIO (do + x <- readChan ch + xs <- getChanContents ch + return (x:xs) + ) + +------------- +writeList2Chan :: Chan a -> [a] -> IO () +writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) diff --git a/libraries/base/Control/Concurrent/MVar.hs b/libraries/base/Control/Concurrent/MVar.hs new file mode 100644 index 0000000000..7832c2eca3 --- /dev/null +++ b/libraries/base/Control/Concurrent/MVar.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.MVar +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: MVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- MVars: Synchronising variables +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.MVar + ( MVar -- abstract + , newEmptyMVar -- :: IO (MVar a) + , newMVar -- :: a -> IO (MVar a) + , takeMVar -- :: MVar a -> IO a + , putMVar -- :: MVar a -> a -> IO () + , readMVar -- :: MVar a -> IO a + , swapMVar -- :: MVar a -> a -> IO a + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool + , isEmptyMVar -- :: MVar a -> IO Bool + , withMVar -- :: MVar a -> (a -> IO b) -> IO b + , modifyMVar_ -- :: MVar a -> (a -> IO a) -> IO () + , modifyMVar -- :: MVar a -> (a -> IO (a,b)) -> IO b + , addMVarFinalizer -- :: MVar a -> IO () -> IO () + ) where + +#ifdef __HUGS__ +import ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, + tryTakeMVar, tryPutMVar, isEmptyMVar, + readMVar, swapMVar, + ) +import Prelude hiding( catch ) +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar, + tryTakeMVar, tryPutMVar, isEmptyMVar, addMVarFinalizer + ) +#endif + +import Control.Exception as Exception + +#ifdef __HUGS__ +-- This is as close as Hugs gets to providing throw +throw :: Exception -> IO a +throw = throwIO +#endif + +#ifdef __GLASGOW_HASKELL__ +readMVar :: MVar a -> IO a +readMVar m = + block $ do + a <- takeMVar m + putMVar m a + return a + +swapMVar :: MVar a -> a -> IO a +swapMVar mvar new = modifyMVar mvar (\old -> return (new,old)) +#endif + +-- put back the same value, return something +withMVar :: MVar a -> (a -> IO b) -> IO b +withMVar m io = + block $ do + a <- takeMVar m + b <- Exception.catch (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a + return b + +-- put back a new value, return () +modifyMVar_ :: MVar a -> (a -> IO a) -> IO () +modifyMVar_ m io = + block $ do + a <- takeMVar m + a' <- Exception.catch (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a' + +-- put back a new value, return something +modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b +modifyMVar m io = + block $ do + a <- takeMVar m + (a',b) <- Exception.catch (unblock (io a)) + (\e -> do putMVar m a; throw e) + putMVar m a' + return b diff --git a/libraries/base/Control/Concurrent/QSem.hs b/libraries/base/Control/Concurrent/QSem.hs new file mode 100644 index 0000000000..6ffba7d5a3 --- /dev/null +++ b/libraries/base/Control/Concurrent/QSem.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.QSem +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: QSem.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- General semaphores +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.QSem + ( QSem, -- abstract + newQSem, -- :: Int -> IO QSem + waitQSem, -- :: QSem -> IO () + signalQSem -- :: QSem -> IO () + ) where + +import Control.Concurrent.MVar + +-- General semaphores are also implemented readily in terms of shared +-- @MVar@s, only have to catch the case when the semaphore is tried +-- waited on when it is empty (==0). Implement this in the same way as +-- shared variables are implemented - maintaining a list of @MVar@s +-- representing threads currently waiting. The counter is a shared +-- variable, ensuring the mutual exclusion on its access. + +newtype QSem = QSem (MVar (Int, [MVar ()])) + +newQSem :: Int -> IO QSem +newQSem init = do + sem <- newMVar (init,[]) + return (QSem sem) + +waitQSem :: QSem -> IO () +waitQSem (QSem sem) = do + (avail,blocked) <- takeMVar sem -- gain ex. access + if avail > 0 then + putMVar sem (avail-1,[]) + else do + block <- newEmptyMVar + {- + Stuff the reader at the back of the queue, + so as to preserve waiting order. A signalling + process then only have to pick the MVar at the + front of the blocked list. + + The version of waitQSem given in the paper could + lead to starvation. + -} + putMVar sem (0, blocked++[block]) + takeMVar block + +signalQSem :: QSem -> IO () +signalQSem (QSem sem) = do + (avail,blocked) <- takeMVar sem + case blocked of + [] -> putMVar sem (avail+1,[]) + + (block:blocked') -> do + putMVar sem (0,blocked') + putMVar block () diff --git a/libraries/base/Control/Concurrent/QSemN.hs b/libraries/base/Control/Concurrent/QSemN.hs new file mode 100644 index 0000000000..da5aa4466a --- /dev/null +++ b/libraries/base/Control/Concurrent/QSemN.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.QSemN +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: QSemN.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Quantity semaphores +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.QSemN + ( QSemN, -- abstract + newQSemN, -- :: Int -> IO QSemN + waitQSemN, -- :: QSemN -> Int -> IO () + signalQSemN -- :: QSemN -> Int -> IO () + ) where + +import Prelude + +import Control.Concurrent.MVar + +newtype QSemN = QSemN (MVar (Int,[(Int,MVar ())])) + +newQSemN :: Int -> IO QSemN +newQSemN init = do + sem <- newMVar (init,[]) + return (QSemN sem) + +waitQSemN :: QSemN -> Int -> IO () +waitQSemN (QSemN sem) sz = do + (avail,blocked) <- takeMVar sem -- gain ex. access + if (avail - sz) >= 0 then + -- discharging 'sz' still leaves the semaphore + -- in an 'unblocked' state. + putMVar sem (avail-sz,[]) + else do + block <- newEmptyMVar + putMVar sem (avail, blocked++[(sz,block)]) + takeMVar block + +signalQSemN :: QSemN -> Int -> IO () +signalQSemN (QSemN sem) n = do + (avail,blocked) <- takeMVar sem + (avail',blocked') <- free (avail+n) blocked + putMVar sem (avail',blocked') + where + free avail [] = return (avail,[]) + free avail ((req,block):blocked) + | avail >= req = do + putMVar block () + free (avail-req) blocked + | otherwise = do + (avail',blocked') <- free avail blocked + return (avail',(req,block):blocked') diff --git a/libraries/base/Control/Concurrent/SampleVar.hs b/libraries/base/Control/Concurrent/SampleVar.hs new file mode 100644 index 0000000000..e3d334108b --- /dev/null +++ b/libraries/base/Control/Concurrent/SampleVar.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Concurrent.SampleVar +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: SampleVar.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Sample variables +-- +----------------------------------------------------------------------------- + +module Control.Concurrent.SampleVar + ( + SampleVar, -- :: type _ = + + newEmptySampleVar, -- :: IO (SampleVar a) + newSampleVar, -- :: a -> IO (SampleVar a) + emptySampleVar, -- :: SampleVar a -> IO () + readSampleVar, -- :: SampleVar a -> IO a + writeSampleVar -- :: SampleVar a -> a -> IO () + + ) where + +import Prelude + +import Control.Concurrent.MVar + +-- Sample variables are slightly different from a normal MVar: +-- +-- * Reading an empty SampleVar causes the reader to block. +-- (same as takeMVar on empty MVar) +-- +-- * Reading a filled SampleVar empties it and returns value. +-- (same as takeMVar) +-- +-- * Writing to an empty SampleVar fills it with a value, and +-- potentially, wakes up a blocked reader (same as for putMVar on +-- empty MVar). +-- +-- * Writing to a filled SampleVar overwrites the current value. +-- (different from putMVar on full MVar.) + +type SampleVar a + = MVar (Int, -- 1 == full + -- 0 == empty + -- <0 no of readers blocked + MVar a) + +-- Initally, a SampleVar is empty/unfilled. + +newEmptySampleVar :: IO (SampleVar a) +newEmptySampleVar = do + v <- newEmptyMVar + newMVar (0,v) + +newSampleVar :: a -> IO (SampleVar a) +newSampleVar a = do + v <- newEmptyMVar + putMVar v a + newMVar (1,v) + +emptySampleVar :: SampleVar a -> IO () +emptySampleVar v = do + (readers, var) <- takeMVar v + if readers >= 0 then + putMVar v (0,var) + else + putMVar v (readers,var) + +-- +-- filled => make empty and grab sample +-- not filled => try to grab value, empty when read val. +-- +readSampleVar :: SampleVar a -> IO a +readSampleVar svar = do + (readers,val) <- takeMVar svar + putMVar svar (readers-1,val) + takeMVar val + +-- +-- filled => overwrite +-- not filled => fill, write val +-- +writeSampleVar :: SampleVar a -> a -> IO () +writeSampleVar svar v = do + (readers,val) <- takeMVar svar + case readers of + 1 -> + swapMVar val v >> + putMVar svar (1,val) + _ -> + putMVar val v >> + putMVar svar (min 1 (readers+1), val) diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs new file mode 100644 index 0000000000..444ac876f6 --- /dev/null +++ b/libraries/base/Control/Exception.hs @@ -0,0 +1,226 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Exception +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Exception.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +-- The External API for exceptions. The functions provided in this +-- module allow catching of exceptions in the IO monad. +-- +----------------------------------------------------------------------------- + +module Control.Exception ( + + Exception(..), -- instance Eq, Ord, Show, Typeable + IOException, -- instance Eq, Ord, Show, Typeable + ArithException(..), -- instance Eq, Ord, Show, Typeable + ArrayException(..), -- instance Eq, Ord, Show, Typeable + AsyncException(..), -- instance Eq, Ord, Show, Typeable + + try, -- :: IO a -> IO (Either Exception a) + tryJust, -- :: (Exception -> Maybe b) -> a -> IO (Either b a) + + catch, -- :: IO a -> (Exception -> IO a) -> IO a + catchJust, -- :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a + + evaluate, -- :: a -> IO a + + -- Exception predicates (for catchJust, tryJust) + + ioErrors, -- :: Exception -> Maybe IOError + arithExceptions, -- :: Exception -> Maybe ArithException + errorCalls, -- :: Exception -> Maybe String + dynExceptions, -- :: Exception -> Maybe Dynamic + assertions, -- :: Exception -> Maybe String + asyncExceptions, -- :: Exception -> Maybe AsyncException + userErrors, -- :: Exception -> Maybe String + + -- Throwing exceptions + + throw, -- :: Exception -> a +#ifndef __STGHUGS__ + -- for now + throwTo, -- :: ThreadId -> Exception -> a +#endif + + -- Dynamic exceptions + + throwDyn, -- :: Typeable ex => ex -> b + throwDynTo, -- :: Typeable ex => ThreadId -> ex -> b + catchDyn, -- :: Typeable ex => IO a -> (ex -> IO a) -> IO a + + -- Async exception control + + block, -- :: IO a -> IO a + unblock, -- :: IO a -> IO a + + -- Assertions + + -- for now + assert, -- :: Bool -> a -> a + + -- Utilities + + finally, -- :: IO a -> IO b -> IO b + + bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO () + bracket_, -- :: IO a -> IO b -> IO c -> IO () + + ) where + +#ifdef __GLASGOW_HASKELL__ +import Prelude hiding (catch) +import GHC.Prim ( assert ) +import GHC.Exception hiding (try, catch, bracket, bracket_) +import GHC.Conc ( throwTo, ThreadId ) +import GHC.IOBase ( IO(..) ) +#endif + +#ifdef __HUGS__ +import Prelude hiding ( catch ) +import PrelPrim ( catchException + , Exception(..) + , throw + , ArithException(..) + , AsyncException(..) + , assert + ) +#endif + +import Data.Dynamic + +#include "Dynamic.h" +INSTANCE_TYPEABLE0(Exception,exceptionTc,"Exception") +INSTANCE_TYPEABLE0(IOException,ioExceptionTc,"IOException") +INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException") +INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException") +INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException") + +----------------------------------------------------------------------------- +-- Catching exceptions + +-- PrelException defines 'catchException' for us. + +catch :: IO a -> (Exception -> IO a) -> IO a +catch = catchException + +catchJust :: (Exception -> Maybe b) -> IO a -> (b -> IO a) -> IO a +catchJust p a handler = catch a handler' + where handler' e = case p e of + Nothing -> throw e + Just b -> handler b + +----------------------------------------------------------------------------- +-- evaluate + +evaluate :: a -> IO a +evaluate a = a `seq` return a + +----------------------------------------------------------------------------- +-- 'try' and variations. + +try :: IO a -> IO (Either Exception a) +try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) + +tryJust :: (Exception -> Maybe b) -> IO a -> IO (Either b a) +tryJust p a = do + r <- try a + case r of + Right v -> return (Right v) + Left e -> case p e of + Nothing -> throw e + Just b -> return (Left b) + +----------------------------------------------------------------------------- +-- Dynamic exception types. Since one of the possible kinds of exception +-- is a dynamically typed value, we can effectively have polymorphic +-- exceptions. + +-- throwDyn will raise any value as an exception, provided it is in the +-- Typeable class (see Dynamic.lhs). + +-- catchDyn will catch any exception of a given type (determined by the +-- handler function). Any raised exceptions that don't match are +-- re-raised. + +throwDyn :: Typeable exception => exception -> b +throwDyn exception = throw (DynException (toDyn exception)) + +throwDynTo :: Typeable exception => ThreadId -> exception -> IO () +throwDynTo t exception = throwTo t (DynException (toDyn exception)) + +catchDyn :: Typeable exception => IO a -> (exception -> IO a) -> IO a +catchDyn m k = catchException m handle + where handle ex = case ex of + (DynException dyn) -> + case fromDynamic dyn of + Just exception -> k exception + Nothing -> throw ex + _ -> throw ex + +----------------------------------------------------------------------------- +-- Exception Predicates + +ioErrors :: Exception -> Maybe IOError +arithExceptions :: Exception -> Maybe ArithException +errorCalls :: Exception -> Maybe String +dynExceptions :: Exception -> Maybe Dynamic +assertions :: Exception -> Maybe String +asyncExceptions :: Exception -> Maybe AsyncException +userErrors :: Exception -> Maybe String + +ioErrors e@(IOException _) = Just e +ioErrors _ = Nothing + +arithExceptions (ArithException e) = Just e +arithExceptions _ = Nothing + +errorCalls (ErrorCall e) = Just e +errorCalls _ = Nothing + +assertions (AssertionFailed e) = Just e +assertions _ = Nothing + +dynExceptions (DynException e) = Just e +dynExceptions _ = Nothing + +asyncExceptions (AsyncException e) = Just e +asyncExceptions _ = Nothing + +userErrors (UserError e) = Just e +userErrors _ = Nothing + +----------------------------------------------------------------------------- +-- Some Useful Functions + +bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracket before after thing = + block (do + a <- before + r <- catch + (unblock (thing a)) + (\e -> do { after a; throw e }) + after a + return r + ) + +-- finally is an instance of bracket, but it's quite common +-- so we give the specialised version for efficiency. +finally :: IO a -> IO b -> IO a +a `finally` sequel = + block (do + r <- catch + (unblock a) + (\e -> do { sequel; throw e }) + sequel + return r + ) + +bracket_ :: IO a -> IO b -> IO c -> IO c +bracket_ before after thing = bracket before (const after) (const thing) diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs new file mode 100644 index 0000000000..d2e9908826 --- /dev/null +++ b/libraries/base/Control/Monad.hs @@ -0,0 +1,160 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Monad.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +----------------------------------------------------------------------------- + +module Control.Monad + ( MonadPlus ( -- class context: Monad + mzero -- :: (MonadPlus m) => m a + , mplus -- :: (MonadPlus m) => m a -> m a -> m a + ) + , join -- :: (Monad m) => m (m a) -> m a + , guard -- :: (MonadPlus m) => Bool -> m () + , when -- :: (Monad m) => Bool -> m () -> m () + , unless -- :: (Monad m) => Bool -> m () -> m () + , ap -- :: (Monad m) => m (a -> b) -> m a -> m b + , msum -- :: (MonadPlus m) => [m a] -> m a + , filterM -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a] + , mapAndUnzipM -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) + , zipWithM -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] + , zipWithM_ -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () + , foldM -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a + + , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b) + , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c) + , liftM3 -- :: ... + , liftM4 -- :: ... + , liftM5 -- :: ... + + , Monad((>>=), (>>), return, fail) + , Functor(fmap) + + , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b] + , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m () + , sequence -- :: (Monad m) => [m a] -> m [a] + , sequence_ -- :: (Monad m) => [m a] -> m () + , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b + ) where + +import Data.Maybe + +#ifdef __GLASGOW_HASKELL__ +import GHC.List +import GHC.Base +#endif + +infixr 1 =<< + +-- ----------------------------------------------------------------------------- +-- Prelude monad functions + +{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f + +sequence :: Monad m => [m a] -> m [a] +{-# INLINE sequence #-} +sequence ms = foldr k (return []) ms + where + k m m' = do { x <- m; xs <- m'; return (x:xs) } + +sequence_ :: Monad m => [m a] -> m () +{-# INLINE sequence_ #-} +sequence_ ms = foldr (>>) (return ()) ms + +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +{-# INLINE mapM #-} +mapM f as = sequence (map f as) + +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +{-# INLINE mapM_ #-} +mapM_ f as = sequence_ (map f as) + +-- ----------------------------------------------------------------------------- +-- Monadic classes: MonadPlus + +class Monad m => MonadPlus m where + mzero :: m a + mplus :: m a -> m a -> m a + +instance MonadPlus [] where + mzero = [] + mplus = (++) + +instance MonadPlus Maybe where + mzero = Nothing + + Nothing `mplus` ys = ys + xs `mplus` _ys = xs + +-- ----------------------------------------------------------------------------- +-- Functions mandated by the Prelude + +guard :: (MonadPlus m) => Bool -> m () +guard True = return () +guard False = mzero + +-- This subsumes the list-based filter function. + +filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] +filterM _ [] = return [] +filterM p (x:xs) = do + flg <- p x + ys <- filterM p xs + return (if flg then x:ys else ys) + +-- This subsumes the list-based concat function. + +msum :: MonadPlus m => [m a] -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- ----------------------------------------------------------------------------- +-- Other monad functions + +join :: (Monad m) => m (m a) -> m a +join x = x >>= id + +mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip + +zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWithM f xs ys = sequence (zipWith f xs ys) + +zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs ys = sequence_ (zipWith f xs ys) + +foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM _ a [] = return a +foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = if p then return () else s + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +ap :: (Monad m) => m (a -> b) -> m a -> m b +ap = liftM2 id + +liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r +liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r +liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r +liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r +liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r + +liftM f m1 = do { x1 <- m1; return (f x1) } +liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } +liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } +liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } +liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } diff --git a/libraries/base/Control/Monad/Cont.hs b/libraries/base/Control/Monad/Cont.hs new file mode 100644 index 0000000000..541f6a6df4 --- /dev/null +++ b/libraries/base/Control/Monad/Cont.hs @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Cont +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Cont.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Continuation monads. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Cont ( + MonadCont(..), + Cont(..), + runCont, + mapCont, + withCont, + ContT(..), + runContT, + mapContT, + withContT, + module Control.Monad, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.RWS + +class (Monad m) => MonadCont m where + callCC :: ((a -> m b) -> m a) -> m a + +-- --------------------------------------------------------------------------- +-- Our parameterizable continuation monad + +newtype Cont r a = Cont { runCont :: (a -> r) -> r } + +instance Functor (Cont r) where + fmap f m = Cont $ \c -> runCont m (c . f) + +instance Monad (Cont r) where + return a = Cont ($ a) + m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c + +instance MonadCont (Cont r) where + callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c + +mapCont :: (r -> r) -> Cont r a -> Cont r a +mapCont f m = Cont $ f . runCont m + +withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b +withCont f m = Cont $ runCont m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable continuation monad, with an inner monad + +newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } + +instance (Monad m) => Functor (ContT r m) where + fmap f m = ContT $ \c -> runContT m (c . f) + +instance (Monad m) => Monad (ContT r m) where + return a = ContT ($ a) + m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c) + +instance (Monad m) => MonadCont (ContT r m) where + callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c + +instance MonadTrans (ContT r) where + lift m = ContT (m >>=) + +instance (MonadIO m) => MonadIO (ContT r m) where + liftIO = lift . liftIO + +instance (MonadReader r' m) => MonadReader r' (ContT r m) where + ask = lift ask + local f m = ContT $ \c -> do + r <- ask + local f (runContT m (local (const r) . c)) + +instance (MonadState s m) => MonadState s (ContT r m) where + get = lift get + put = lift . put + +-- ----------------------------------------------------------------------------- +-- MonadCont instances for other monad transformers + +instance (MonadCont m) => MonadCont (ReaderT r m) where + callCC f = ReaderT $ \r -> + callCC $ \c -> + runReaderT (f (\a -> ReaderT $ \_ -> c a)) r + +instance (MonadCont m) => MonadCont (StateT s m) where + callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s + +instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where + callCC f = WriterT $ + callCC $ \c -> + runWriterT (f (\a -> WriterT $ c (a, mempty))) + +instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where + callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s + +mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a +mapContT f m = ContT $ f . runContT m + +withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b +withContT f m = ContT $ runContT m . f diff --git a/libraries/base/Control/Monad/Error.hs b/libraries/base/Control/Monad/Error.hs new file mode 100644 index 0000000000..979ae35b4c --- /dev/null +++ b/libraries/base/Control/Monad/Error.hs @@ -0,0 +1,224 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Error +-- Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de>, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (reqruires multi-param type classes) +-- +-- $Id: Error.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Error monad. +-- +-- Rendered by Michael Weber <michael.weber@post.rwth-aachen.de>, +-- inspired by the Haskell Monad Template Library from +-- \A[HREF="http://www.cse.ogi.edu/~andy"]{Andy Gill}} +-- +----------------------------------------------------------------------------- + +module Control.Monad.Error ( + Error(..), + MonadError(..), + ErrorT(..), + runErrorT, + mapErrorT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.RWS +import Control.Monad.Cont + +import System.IO + +-- --------------------------------------------------------------------------- +-- class MonadError +-- +-- throws an exception inside the monad and thus interrupts +-- normal execution order, until an error handler is reached} +-- +-- catches an exception inside the monad (that was previously +-- thrown by throwError + +class Error a where + noMsg :: a + strMsg :: String -> a + + noMsg = strMsg "" + strMsg _ = noMsg + +instance Error [Char] where + noMsg = "" + strMsg = id + +instance Error IOError where + strMsg = userError + +class (Monad m) => MonadError e m | m -> e where + throwError :: e -> m a + catchError :: m a -> (e -> m a) -> m a + +instance MonadPlus IO where + mzero = ioError (userError "mzero") + m `mplus` n = m `catch` \_ -> n + +instance MonadError IOError IO where + throwError = ioError + catchError = catch + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad + +instance Functor (Either e) where + fmap _ (Left l) = Left l + fmap f (Right r) = Right (f r) + +instance (Error e) => Monad (Either e) where + return = Right + Left l >>= _ = Left l + Right r >>= k = k r + fail msg = Left (strMsg msg) + +instance (Error e) => MonadPlus (Either e) where + mzero = Left noMsg + Left _ `mplus` n = n + m `mplus` _ = m + +instance (Error e) => MonadFix (Either e) where + mfix f = let + a = f $ case a of + Right r -> r + _ -> error "empty mfix argument" + in a + +instance (Error e) => MonadError e (Either e) where + throwError = Left + Left l `catchError` h = h l + Right r `catchError` _ = Right r + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad, with an inner monad + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +-- The ErrorT Monad structure is parameterized over two things: +-- * e - The error type. +-- * m - The inner monad. + +-- Here are some examples of use: +-- +-- type ErrorWithIO e a = ErrorT e IO a +-- ==> ErrorT (IO (Either e a)) +-- +-- type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a +-- ==> ErrorT (StateT s IO (Either e a)) +-- ==> ErrorT (StateT (s -> IO (Either e a,s))) +-- + +instance (Monad m) => Functor (ErrorT e m) where + fmap f m = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> return (Right (f r)) + +instance (Monad m, Error e) => Monad (ErrorT e m) where + return a = ErrorT $ return (Right a) + m >>= k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) + fail msg = ErrorT $ return (Left (strMsg msg)) + +instance (Monad m, Error e) => MonadPlus (ErrorT e m) where + mzero = ErrorT $ return (Left noMsg) + m `mplus` n = ErrorT $ do + a <- runErrorT m + case a of + Left _ -> runErrorT n + Right r -> return (Right r) + +instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of + Right r -> r + _ -> error "empty mfix argument" + +instance (Monad m, Error e) => MonadError e (ErrorT e m) where + throwError l = ErrorT $ return (Left l) + m `catchError` h = ErrorT $ do + a <- runErrorT m + case a of + Left l -> runErrorT (h l) + Right r -> return (Right r) + +instance (Error e) => MonadTrans (ErrorT e) where + lift m = ErrorT $ do + a <- m + return (Right a) + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where + ask = lift ask + local f m = ErrorT $ local f (runErrorT m) + +instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where + tell = lift . tell + listen m = ErrorT $ do + (a, w) <- listen (runErrorT m) + return $ case a of + Left l -> Left l + Right r -> Right (r, w) + pass m = ErrorT $ pass $ do + a <- runErrorT m + return $ case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) + +instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where + get = lift get + put = lift . put + +instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where + callCC f = ErrorT $ + callCC $ \c -> + runErrorT (f (\a -> ErrorT $ c (Right a))) + +mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) + +-- --------------------------------------------------------------------------- +-- MonadError instances for other monad transformers + +instance (MonadError e m) => MonadError e (ReaderT r m) where + throwError = lift . throwError + m `catchError` h = ReaderT $ \r -> runReaderT m r + `catchError` \e -> runReaderT (h e) r + +instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where + throwError = lift . throwError + m `catchError` h = WriterT $ runWriterT m + `catchError` \e -> runWriterT (h e) + +instance (MonadError e m) => MonadError e (StateT s m) where + throwError = lift . throwError + m `catchError` h = StateT $ \s -> runStateT m s + `catchError` \e -> runStateT (h e) s + +instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where + throwError = lift . throwError + m `catchError` h = RWST $ \r s -> runRWST m r s + `catchError` \e -> runRWST (h e) r s diff --git a/libraries/base/Control/Monad/Fix.hs b/libraries/base/Control/Monad/Fix.hs new file mode 100644 index 0000000000..a596f445fc --- /dev/null +++ b/libraries/base/Control/Monad/Fix.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Fix +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (reqruires multi-param type classes) +-- +-- $Id: Fix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Fix monad. +-- +-- Inspired by the paper: +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +-- +----------------------------------------------------------------------------- + +module Control.Monad.Fix ( + MonadFix( + mfix -- :: (a -> m a) -> m a + ), + fix -- :: (a -> a) -> a + ) where + +import Prelude + +import System.IO +import Control.Monad.ST + + +fix :: (a -> a) -> a +fix f = let x = f x in x + +class (Monad m) => MonadFix m where + mfix :: (a -> m a) -> m a + +-- Perhaps these should live beside (the ST & IO) definition. +instance MonadFix IO where + mfix = fixIO + +instance MonadFix (ST s) where + mfix = fixST + +instance MonadFix Maybe where + mfix f = let + a = f $ case a of + Just x -> x + _ -> error "empty mfix argument" + in a diff --git a/libraries/base/Control/Monad/Identity.hs b/libraries/base/Control/Monad/Identity.hs new file mode 100644 index 0000000000..aee6f031da --- /dev/null +++ b/libraries/base/Control/Monad/Identity.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- $Id: Identity.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Identity monad. +-- +-- Inspired by the paper: +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +-- +----------------------------------------------------------------------------- + +module Control.Monad.Identity ( + Identity(..), + runIdentity, + module Control.Monad, + module Control.Monad.Fix, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- Identity wrapper +-- +-- Abstraction for wrapping up a object. +-- If you have an monadic function, say: +-- +-- example :: Int -> IdentityMonad Int +-- example x = return (x*x) +-- +-- you can "run" it, using +-- +-- Main> runIdentity (example 42) +-- 1764 :: Int + +newtype Identity a = Identity { runIdentity :: a } + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) diff --git a/libraries/base/Control/Monad/List.hs b/libraries/base/Control/Monad/List.hs new file mode 100644 index 0000000000..e6c7daa23a --- /dev/null +++ b/libraries/base/Control/Monad/List.hs @@ -0,0 +1,87 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.List +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes ) +-- +-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The List monad. +-- +----------------------------------------------------------------------------- + +module Control.Monad.List ( + ListT(..), + runListT, + mapListT, + module Control.Monad, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Cont +import Control.Monad.Error + +-- --------------------------------------------------------------------------- +-- Our parameterizable list monad, with an inner monad + +newtype ListT m a = ListT { runListT :: m [a] } + +instance (Monad m) => Functor (ListT m) where + fmap f m = ListT $ do + a <- runListT m + return (map f a) + +instance (Monad m) => Monad (ListT m) where + return a = ListT $ return [a] + m >>= k = ListT $ do + a <- runListT m + b <- mapM (runListT . k) a + return (concat b) + fail _ = ListT $ return [] + +instance (Monad m) => MonadPlus (ListT m) where + mzero = ListT $ return [] + m `mplus` n = ListT $ do + a <- runListT m + b <- runListT n + return (a ++ b) + +instance MonadTrans ListT where + lift m = ListT $ do + a <- m + return [a] + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + +instance (MonadReader s m) => MonadReader s (ListT m) where + ask = lift ask + local f m = ListT $ local f (runListT m) + +instance (MonadState s m) => MonadState s (ListT m) where + get = lift get + put = lift . put + +instance (MonadCont m) => MonadCont (ListT m) where + callCC f = ListT $ + callCC $ \c -> + runListT (f (\a -> ListT $ c [a])) + +instance (MonadError e m) => MonadError e (ListT m) where + throwError = lift . throwError + m `catchError` h = ListT $ runListT m + `catchError` \e -> runListT (h e) + +mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b +mapListT f m = ListT $ f (runListT m) diff --git a/libraries/base/Control/Monad/Monoid.hs b/libraries/base/Control/Monad/Monoid.hs new file mode 100644 index 0000000000..e81b2be798 --- /dev/null +++ b/libraries/base/Control/Monad/Monoid.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Monoid +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes ) +-- +-- $Id: Monoid.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Declaration of the Monoid class,and instances for list and functions +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.Monoid ( + Monoid(..) + ) where + +import Prelude + +-- --------------------------------------------------------------------------- +-- The Monoid class + +class Monoid a where + mempty :: a + mappend :: a -> a -> a + mconcat :: [a] -> a + +-- Now the default for mconcat. For most types, this +-- default will be used, but is included in the class definition so +-- that optimized version of mconcat can be provided +-- for specific types. + + mconcat = foldr mappend mempty + +-- Monoid instances. + +instance Monoid [a] where + mempty = [] + mappend = (++) + +instance Monoid (a -> a) where + mempty = id + mappend = (.) + +instance Monoid () where + -- Should it be strict? + mempty = () + _ `mappend` _ = () + mconcat _ = () diff --git a/libraries/base/Control/Monad/RWS.hs b/libraries/base/Control/Monad/RWS.hs new file mode 100644 index 0000000000..26d624d0e4 --- /dev/null +++ b/libraries/base/Control/Monad/RWS.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.RWS +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes, +-- requires functional dependencies ) +-- +-- $Id: RWS.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Declaration of the MonadRWS class. +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.RWS ( + RWS(..), + runRWS, + evalRWS, + execRWS, + mapRWS, + withRWS, + RWST(..), + runRWST, + evalRWST, + execRWST, + mapRWST, + withRWST, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Control.Monad.Reader, + module Control.Monad.Writer, + module Control.Monad.State, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Monoid +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State + + +newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) } + +instance Functor (RWS r w s) where + fmap f m = RWS $ \r s -> let + (a, s', w) = runRWS m r s + in (f a, s', w) + +instance (Monoid w) => Monad (RWS r w s) where + return a = RWS $ \_ s -> (a, s, mempty) + m >>= k = RWS $ \r s -> let + (a, s', w) = runRWS m r s + (b, s'', w') = runRWS (k a) r s' + in (b, s'', w `mappend` w') + +instance (Monoid w) => MonadFix (RWS r w s) where + mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w) + +instance (Monoid w) => MonadReader r (RWS r w s) where + ask = RWS $ \r s -> (r, s, mempty) + local f m = RWS $ \r s -> runRWS m (f r) s + +instance (Monoid w) => MonadWriter w (RWS r w s) where + tell w = RWS $ \_ s -> ((), s, w) + listen m = RWS $ \r s -> let + (a, s', w) = runRWS m r s + in ((a, w), s', w) + pass m = RWS $ \r s -> let + ((a, f), s', w) = runRWS m r s + in (a, s', f w) + +instance (Monoid w) => MonadState s (RWS r w s) where + get = RWS $ \_ s -> (s, s, mempty) + put s = RWS $ \_ _ -> ((), s, mempty) + + +evalRWS :: RWS r w s a -> r -> s -> (a, w) +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) + +execRWS :: RWS r w s a -> r -> s -> (s, w) +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) + +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f m = RWS $ \r s -> f (runRWS m r s) + +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s) + + +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +instance (Monad m) => Functor (RWST r w s m) where + fmap f m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return (f a, s', w) + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where + return a = RWST $ \_ s -> return (a, s, mempty) + m >>= k = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + (b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + fail msg = RWST $ \_ _ -> fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \_ _ -> mzero + m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + +instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where + ask = RWST $ \r s -> return (r, s, mempty) + local f m = RWST $ \r s -> runRWST m (f r) s + +instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where + tell w = RWST $ \_ s -> return ((),s,w) + listen m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return ((a, w), s', w) + pass m = RWST $ \r s -> do + ((a, f), s', w) <- runRWST m r s + return (a, s', f w) + +instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where + get = RWST $ \_ s -> return (s, s, mempty) + put s = RWST $ \_ _ -> return ((), s, mempty) + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \_ s -> do + a <- m + return (a, s, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + + +evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w) +evalRWST m r s = do + (a, _, w) <- runRWST m r s + return (a, w) + +execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w) +execRWST m r s = do + (_, s', w) <- runRWST m r s + return (s', w) + +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \r s -> f (runRWST m r s) + +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s) diff --git a/libraries/base/Control/Monad/Reader.hs b/libraries/base/Control/Monad/Reader.hs new file mode 100644 index 0000000000..d03c446aee --- /dev/null +++ b/libraries/base/Control/Monad/Reader.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Reader +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes, +-- requires functional dependencies ) +-- +-- $Id: Reader.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Declaration of the Monoid class,and instances for list and functions +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.Reader ( + MonadReader(..), + asks, + Reader(..), + runReader, + mapReader, + withReader, + ReaderT(..), + runReaderT, + mapReaderT, + withReaderT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans + +-- ---------------------------------------------------------------------------- +-- class MonadReader +-- asks for the internal (non-mutable) state. + +class (Monad m) => MonadReader r m | m -> r where + ask :: m r + local :: (r -> r) -> m a -> m a + +-- This allows you to provide a projection function. + +asks :: (MonadReader r m) => (r -> a) -> m a +asks f = do + r <- ask + return (f r) + +-- ---------------------------------------------------------------------------- +-- The partially applied function type is a simple reader monad + +instance Functor ((->) r) where + fmap = (.) + +instance Monad ((->) r) where + return = const + m >>= k = \r -> k (m r) r + +instance MonadFix ((->) r) where + mfix f = \r -> let a = f a r in a + +instance MonadReader r ((->) r) where + ask = id + local f m = m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable reader monad + +newtype Reader r a = Reader { runReader :: r -> a } + +instance Functor (Reader r) where + fmap f m = Reader $ \r -> f (runReader m r) + +instance Monad (Reader r) where + return a = Reader $ \_ -> a + m >>= k = Reader $ \r -> runReader (k (runReader m r)) r + +instance MonadFix (Reader r) where + mfix f = Reader $ \r -> let a = runReader (f a) r in a + +instance MonadReader r (Reader r) where + ask = Reader id + local f m = Reader $ runReader m . f + +mapReader :: (a -> b) -> Reader r a -> Reader r b +mapReader f m = Reader $ f . runReader m + +-- This is a more general version of local. + +withReader :: (r' -> r) -> Reader r a -> Reader r' a +withReader f m = Reader $ runReader m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable reader monad, with an inner monad + +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } + +instance (Monad m) => Functor (ReaderT r m) where + fmap f m = ReaderT $ \r -> do + a <- runReaderT m r + return (f a) + +instance (Monad m) => Monad (ReaderT r m) where + return a = ReaderT $ \_ -> return a + m >>= k = ReaderT $ \r -> do + a <- runReaderT m r + runReaderT (k a) r + fail msg = ReaderT $ \_ -> fail msg + +instance (MonadPlus m) => MonadPlus (ReaderT r m) where + mzero = ReaderT $ \_ -> mzero + m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r + +instance (MonadFix m) => MonadFix (ReaderT r m) where + mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r + +instance (Monad m) => MonadReader r (ReaderT r m) where + ask = ReaderT return + local f m = ReaderT $ \r -> runReaderT m (f r) + +instance MonadTrans (ReaderT r) where + lift m = ReaderT $ \_ -> m + +instance (MonadIO m) => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + +mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b +mapReaderT f m = ReaderT $ f . runReaderT m + +withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a +withReaderT f m = ReaderT $ runReaderT m . f diff --git a/libraries/base/Control/Monad/ST.hs b/libraries/base/Control/Monad/ST.hs new file mode 100644 index 0000000000..6cbae953d3 --- /dev/null +++ b/libraries/base/Control/Monad/ST.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.ST +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The State Transformer Monad, ST +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST + ( + ST -- abstract, instance of Functor, Monad, Typeable. + , runST -- :: (forall s. ST s a) -> a + , fixST -- :: (a -> ST s a) -> ST s a + , unsafeInterleaveST -- :: ST s a -> ST s a + + , unsafeIOToST -- :: IO a -> ST s a + + , RealWorld -- abstract + , stToIO -- :: ST RealWorld a -> IO a + ) where + +import Prelude + +import Data.Dynamic + +#ifdef __GLASGOW_HASKELL__ +import GHC.ST +import GHC.Prim ( unsafeCoerce#, RealWorld ) +import GHC.IOBase ( IO(..), stToIO ) + +unsafeIOToST :: IO a -> ST s a +unsafeIOToST (IO io) = ST $ \ s -> + case ((unsafeCoerce# io) s) of + (# new_s, a #) -> unsafeCoerce# (STret new_s a) +#endif + +-- --------------------------------------------------------------------------- +-- Typeable instance + +sTTc :: TyCon +sTTc = mkTyCon "ST" + +instance (Typeable a, Typeable b) => Typeable (ST a b) where + typeOf st = mkAppTy sTTc [typeOf ((undefined :: ST a b -> a) st), + typeOf ((undefined :: ST a b -> b) st)] diff --git a/libraries/base/Control/Monad/ST/Lazy.hs b/libraries/base/Control/Monad/ST/Lazy.hs new file mode 100644 index 0000000000..24b396d686 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Lazy.hs @@ -0,0 +1,247 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.ST.Lazy +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Lazy.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- This module presents an identical interface to Control.Monad.ST, +-- but the underlying implementation of the state thread is lazy. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Lazy ( + ST, + + runST, + unsafeInterleaveST, + fixST, + + STRef.STRef, + newSTRef, readSTRef, writeSTRef, + + STArray.STArray, + newSTArray, readSTArray, writeSTArray, boundsSTArray, + thawSTArray, freezeSTArray, unsafeFreezeSTArray, +#ifdef __GLASGOW_HASKELL__ +-- no 'good' reason, just doesn't support it right now. + unsafeThawSTArray, +#endif + + ST.unsafeIOToST, ST.stToIO, + + strictToLazyST, lazyToStrictST + ) where + +import Prelude + +import qualified Data.STRef as STRef +import Data.Array + +#ifdef __GLASGOW_HASKELL__ +import qualified Control.Monad.ST as ST +import qualified GHC.Arr as STArray +import qualified GHC.ST +import GHC.Base ( ($), ()(..) ) +import Control.Monad +import Data.Ix +import GHC.Prim +#endif + +#ifdef __HUGS__ +import qualified ST +import Monad +import Ix +import Array +import PrelPrim ( unST + , mkST + , PrimMutableArray + , PrimArray + , primNewArray + , primReadArray + , primWriteArray + , primUnsafeFreezeArray + , primSizeMutableArray + , primSizeArray + , primIndexArray + ) +#endif + + +#ifdef __GLASGOW_HASKELL__ +newtype ST s a = ST (State s -> (a, State s)) +data State s = S# (State# s) +#endif + +#ifdef __HUGS__ +newtype ST s a = ST (s -> (a,s)) +#endif + +instance Functor (ST s) where + fmap f m = ST $ \ s -> + let + ST m_a = m + (r,new_s) = m_a s + in + (f r,new_s) + +instance Monad (ST s) where + + return a = ST $ \ s -> (a,s) + m >> k = m >>= \ _ -> k + fail s = error s + + (ST m) >>= k + = ST $ \ s -> + let + (r,new_s) = m s + ST k_a = k r + in + k_a new_s + + +#ifdef __GLASGOW_HASKELL__ +{-# NOINLINE runST #-} +runST :: (forall s. ST s a) -> a +runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r +#endif + +#ifdef __HUGS__ +runST :: (__forall s. ST s a) -> a +runST st = case st of ST the_st -> let (r,_) = the_st realWorld in r + where realWorld = error "runST: entered the RealWorld" +#endif + +fixST :: (a -> ST s a) -> ST s a +fixST m = ST (\ s -> + let + ST m_r = m r + (r,s) = m_r s + in + (r,s)) + +-- --------------------------------------------------------------------------- +-- Variables + +newSTRef :: a -> ST s (STRef.STRef s a) +readSTRef :: STRef.STRef s a -> ST s a +writeSTRef :: STRef.STRef s a -> a -> ST s () + +newSTRef = strictToLazyST . STRef.newSTRef +readSTRef = strictToLazyST . STRef.readSTRef +writeSTRef r a = strictToLazyST (STRef.writeSTRef r a) + +-- -------------------------------------------------------------------------- +-- Arrays + +newSTArray :: Ix ix => (ix,ix) -> elt -> ST s (STArray.STArray s ix elt) +readSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> ST s elt +writeSTArray :: Ix ix => STArray.STArray s ix elt -> ix -> elt -> ST s () +boundsSTArray :: Ix ix => STArray.STArray s ix elt -> (ix, ix) +thawSTArray :: Ix ix => Array ix elt -> ST s (STArray.STArray s ix elt) +freezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt) +unsafeFreezeSTArray :: Ix ix => STArray.STArray s ix elt -> ST s (Array ix elt) + +#ifdef __GLASGOW_HASKELL__ + +newSTArray ixs init = strictToLazyST (STArray.newSTArray ixs init) + +readSTArray arr ix = strictToLazyST (STArray.readSTArray arr ix) +writeSTArray arr ix v = strictToLazyST (STArray.writeSTArray arr ix v) +boundsSTArray arr = STArray.boundsSTArray arr +thawSTArray arr = strictToLazyST (STArray.thawSTArray arr) +freezeSTArray arr = strictToLazyST (STArray.freezeSTArray arr) +unsafeFreezeSTArray arr = strictToLazyST (STArray.unsafeFreezeSTArray arr) +unsafeThawSTArray arr = strictToLazyST (STArray.unsafeThawSTArray arr) +#endif + + +#ifdef __HUGS__ +newSTArray ixs elt = do + { arr <- strictToLazyST (primNewArray (rangeSize ixs) elt) + ; return (STArray ixs arr) + } + +boundsSTArray (STArray ixs arr) = ixs +readSTArray (STArray ixs arr) ix + = strictToLazyST (primReadArray arr (index ixs ix)) +writeSTArray (STArray ixs arr) ix elt + = strictToLazyST (primWriteArray arr (index ixs ix) elt) +freezeSTArray (STArray ixs arr) = do + { arr' <- strictToLazyST (primFreezeArray arr) + ; return (Array ixs arr') + } + +unsafeFreezeSTArray (STArray ixs arr) = do + { arr' <- strictToLazyST (primUnsafeFreezeArray arr) + ; return (Array ixs arr') + } + +thawSTArray (Array ixs arr) = do + { arr' <- strictToLazyST (primThawArray arr) + ; return (STArray ixs arr') + } + +primFreezeArray :: PrimMutableArray s a -> ST.ST s (PrimArray a) +primFreezeArray arr = do + { let n = primSizeMutableArray arr + ; arr' <- primNewArray n arrEleBottom + ; mapM_ (copy arr arr') [0..n-1] + ; primUnsafeFreezeArray arr' + } + where + copy arr arr' i = do { x <- primReadArray arr i; primWriteArray arr' i x } + arrEleBottom = error "primFreezeArray: panic" + +primThawArray :: PrimArray a -> ST.ST s (PrimMutableArray s a) +primThawArray arr = do + { let n = primSizeArray arr + ; arr' <- primNewArray n arrEleBottom + ; mapM_ (copy arr arr') [0..n-1] + ; return arr' + } + where + copy arr arr' i = primWriteArray arr' i (primIndexArray arr i) + arrEleBottom = error "primFreezeArray: panic" +#endif + +-- --------------------------------------------------------------------------- +-- Strict <--> Lazy + +#ifdef __GLASGOW_HASKELL__ +strictToLazyST :: ST.ST s a -> ST s a +strictToLazyST m = ST $ \s -> + let + pr = case s of { S# s# -> GHC.ST.liftST m s# } + r = case pr of { GHC.ST.STret _ v -> v } + s' = case pr of { GHC.ST.STret s2# _ -> S# s2# } + in + (r, s') + +lazyToStrictST :: ST s a -> ST.ST s a +lazyToStrictST (ST m) = GHC.ST.ST $ \s -> + case (m (S# s)) of (a, S# s') -> (# s', a #) +#endif + +#ifdef __HUGS__ +strictToLazyST :: ST.ST s a -> ST s a +strictToLazyST m = ST $ \s -> + let + pr = unST m s + r = fst pr + s' = snd pr + in + (r, s') + + +lazyToStrictST :: ST s a -> ST.ST s a +lazyToStrictST (ST m) = mkST $ m +#endif + +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST diff --git a/libraries/base/Control/Monad/ST/Strict.hs b/libraries/base/Control/Monad/ST/Strict.hs new file mode 100644 index 0000000000..927c462b48 --- /dev/null +++ b/libraries/base/Control/Monad/ST/Strict.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.ST.Strict +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Strict.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The strict ST monad (identical to Control.Monad.ST) +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Strict ( + module Control.Monad.ST + ) where + +import Prelude +import Control.Monad.ST diff --git a/libraries/base/Control/Monad/State.hs b/libraries/base/Control/Monad/State.hs new file mode 100644 index 0000000000..b28d027c4c --- /dev/null +++ b/libraries/base/Control/Monad/State.hs @@ -0,0 +1,227 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.State +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes, +-- requires functional dependencies ) +-- +-- $Id: State.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- State monads. +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.State ( + MonadState(..), + modify, + gets, + State(..), + runState, + evalState, + execState, + mapState, + withState, + StateT(..), + runStateT, + evalStateT, + execStateT, + mapStateT, + withStateT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer + +-- --------------------------------------------------------------------------- +-- MonadState class +-- +-- get: returns the state from the internals of the monad. +-- put: changes (replaces) the state inside the monad. + +class (Monad m) => MonadState s m | m -> s where + get :: m s + put :: s -> m () + +-- Monadic state transformer. +-- +-- Maps an old state to a new state inside a state monad. +-- The old state is thrown away.} +-- +-- Main> :t modify ((+1) :: Int -> Int) +-- modify (...) :: (MonadState Int a) => a () +-- +-- This says that modify (+1) acts over any +-- Monad that is a member of the MonadState class, +-- with an Int state. + +modify :: (MonadState s m) => (s -> s) -> m () +modify f = do + s <- get + put (f s) + +-- Get part of the state +-- +-- gets specific component of the state, +-- using a projection function supplied. + +gets :: (MonadState s m) => (s -> a) -> m a +gets f = do + s <- get + return (f s) + +-- --------------------------------------------------------------------------- +-- Our parameterizable state monad + +newtype State s a = State { runState :: s -> (a, s) } + +-- The State Monad structure is paramterized over just the state. + +instance Functor (State s) where + fmap f m = State $ \s -> let + (a, s') = runState m s + in (f a, s') + +instance Monad (State s) where + return a = State $ \s -> (a, s) + m >>= k = State $ \s -> let + (a, s') = runState m s + in runState (k a) s' + +instance MonadFix (State s) where + mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s') + +instance MonadState s (State s) where + get = State $ \s -> (s, s) + put s = State $ \_ -> ((), s) + + +evalState :: State s a -> s -> a +evalState m s = fst (runState m s) + +execState :: State s a -> s -> s +execState m s = snd (runState m s) + +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f m = State $ f . runState m + +withState :: (s -> s) -> State s a -> State s a +withState f m = State $ runState m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable state monad, with an inner monad + +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +--The StateT Monad structure is parameterized over two things: +-- +-- * s - The state. +-- * m - The inner monad. + +-- Here are some examples of use: + +-- (Parser from ParseLib with Hugs) +-- type Parser a = StateT String [] a +-- ==> StateT (String -> [(a,String)]) +-- For example, item can be written as: +-- item = do (x:xs) <- get +-- put xs +-- return x + +-- type BoringState s a = StateT s Indentity a +-- ==> StateT (s -> Identity (a,s)) +-- +-- type StateWithIO s a = StateT s IO a +-- ==> StateT (s -> IO (a,s)) +-- +-- type StateWithErr s a = StateT s Maybe a +-- ==> StateT (s -> Maybe (a,s)) + +instance (Monad m) => Functor (StateT s m) where + fmap f m = StateT $ \s -> do + (x, s') <- runStateT m s + return (f x, s') + +instance (Monad m) => Monad (StateT s m) where + return a = StateT $ \s -> return (a, s) + m >>= k = StateT $ \s -> do + (a, s') <- runStateT m s + runStateT (k a) s' + fail str = StateT $ \_ -> fail str + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \_ -> mzero + m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s + +instance (Monad m) => MonadState s (StateT s m) where + get = StateT $ \s -> return (s, s) + put s = StateT $ \_ -> return ((), s) + +instance MonadTrans (StateT s) where + lift m = StateT $ \s -> do + a <- m + return (a, s) + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + +instance (MonadReader r m) => MonadReader r (StateT s m) where + ask = lift ask + local f m = StateT $ \s -> local f (runStateT m s) + +instance (MonadWriter w m) => MonadWriter w (StateT s m) where + tell = lift . tell + listen m = StateT $ \s -> do + ((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') + pass m = StateT $ \s -> pass $ do + ((a, f), s') <- runStateT m s + return ((a, s'), f) + + +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + (a, _) <- runStateT m s + return a + +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + (_, s') <- runStateT m s + return s' + +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m + +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f + +-- --------------------------------------------------------------------------- +-- MonadState instances for other monad transformers + +instance (MonadState s m) => MonadState s (ReaderT r m) where + get = lift get + put = lift . put + +instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where + get = lift get + put = lift . put diff --git a/libraries/base/Control/Monad/Trans.hs b/libraries/base/Control/Monad/Trans.hs new file mode 100644 index 0000000000..376602107f --- /dev/null +++ b/libraries/base/Control/Monad/Trans.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Trans +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- $Id: Trans.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The MonadTrans class. +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.Trans ( + MonadTrans(..), + MonadIO(..), + ) where + +import Prelude + +import System.IO + +-- --------------------------------------------------------------------------- +-- MonadTrans class +-- +-- Monad to facilitate stackable Monads. +-- Provides a way of digging into an outer +-- monad, giving access to (lifting) the inner monad. + +class MonadTrans t where + lift :: Monad m => m a -> t m a + +class (Monad m) => MonadIO m where + liftIO :: IO a -> m a + +instance MonadIO IO where + liftIO = id diff --git a/libraries/base/Control/Monad/Writer.hs b/libraries/base/Control/Monad/Writer.hs new file mode 100644 index 0000000000..96df1307be --- /dev/null +++ b/libraries/base/Control/Monad/Writer.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Monad.Writer +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable ( requires mulit-parameter type classes, +-- requires functional dependencies ) +-- +-- $Id: Writer.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The MonadWriter class. +-- +-- Inspired by the paper +-- \em{Functional Programming with Overloading and +-- Higher-Order Polymorphism}, +-- \A[HREF="http://www.cse.ogi.edu/~mpj"]{Mark P Jones}, +-- Advanced School of Functional Programming, 1995.} +----------------------------------------------------------------------------- + +module Control.Monad.Writer ( + MonadWriter(..), + listens, + censor, + Writer(..), + runWriter, + execWriter, + mapWriter, + WriterT(..), + runWriterT, + execWriterT, + mapWriterT, + module Control.Monad, + module Control.Monad.Monoid, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Monoid +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader + +-- --------------------------------------------------------------------------- +-- MonadWriter class +-- +-- tell is like tell on the MUD's it shouts to monad +-- what you want to be heard. The monad carries this 'packet' +-- upwards, merging it if needed (hence the Monoid requirement)} +-- +-- listen listens to a monad acting, and returns what the monad "said". +-- +-- pass lets you provide a writer transformer which changes internals of +-- the written object. + +class (Monoid w, Monad m) => MonadWriter w m | m -> w where + tell :: w -> m () + listen :: m a -> m (a, w) + pass :: m (a, w -> w) -> m a + +listens :: (MonadWriter w m) => (w -> w) -> m a -> m (a, w) +listens f m = do + (a, w) <- listen m + return (a, f w) + +censor :: (MonadWriter w m) => (w -> w) -> m a -> m a +censor f m = pass $ do + a <- m + return (a, f) + +-- --------------------------------------------------------------------------- +-- Our parameterizable writer monad + +newtype Writer w a = Writer { runWriter :: (a, w) } + + +instance Functor (Writer w) where + fmap f m = Writer $ let (a, w) = runWriter m in (f a, w) + +instance (Monoid w) => Monad (Writer w) where + return a = Writer (a, mempty) + m >>= k = Writer $ let + (a, w) = runWriter m + (b, w') = runWriter (k a) + in (b, w `mappend` w') + +instance (Monoid w) => MonadFix (Writer w) where + mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w) + +instance (Monoid w) => MonadWriter w (Writer w) where + tell w = Writer ((), w) + listen m = Writer $ let (a, w) = runWriter m in ((a, w), w) + pass m = Writer $ let ((a, f), w) = runWriter m in (a, f w) + + +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) + +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f m = Writer $ f (runWriter m) + +-- --------------------------------------------------------------------------- +-- Our parameterizable writer monad, with an inner monad + +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + + +instance (Monad m) => Functor (WriterT w m) where + fmap f m = WriterT $ do + (a, w) <- runWriterT m + return (f a, w) + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + return a = WriterT $ return (a, mempty) + m >>= k = WriterT $ do + (a, w) <- runWriterT m + (b, w') <- runWriterT (k a) + return (b, w `mappend` w') + fail msg = WriterT $ fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + +instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where + tell w = WriterT $ return ((), w) + listen m = WriterT $ do + (a, w) <- runWriterT m + return ((a, w), w) + pass m = WriterT $ do + ((a, f), w) <- runWriterT m + return (a, f w) + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + +instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where + ask = lift ask + local f m = WriterT $ local f (runWriterT m) + + +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT m = do + (_, w) <- runWriterT m + return w + +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) + +-- --------------------------------------------------------------------------- +-- MonadWriter instances for other monad transformers + +instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where + tell = lift . tell + listen m = ReaderT $ \w -> listen (runReaderT m w) + pass m = ReaderT $ \w -> pass (runReaderT m w) diff --git a/libraries/base/Control/Parallel.hs b/libraries/base/Control/Parallel.hs new file mode 100644 index 0000000000..1d6a126f1e --- /dev/null +++ b/libraries/base/Control/Parallel.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Parallel +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Parallel.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +-- Parallel Constructs +-- +----------------------------------------------------------------------------- + +module Control.Parallel ( + par, seq -- re-exported +#if defined(__GRANSIM__) + , parGlobal, parLocal, parAt, parAtAbs, parAtRel, parAtForNow +#endif + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.Conc ( par ) +#endif + +#if defined(__GRANSIM__) +import PrelBase +import PrelErr ( parError ) +import PrelGHC ( parGlobal#, parLocal#, parAt#, parAtAbs#, parAtRel#, parAtForNow# ) + +{-# INLINE parGlobal #-} +{-# INLINE parLocal #-} +{-# INLINE parAt #-} +{-# INLINE parAtAbs #-} +{-# INLINE parAtRel #-} +{-# INLINE parAtForNow #-} +parGlobal :: Int -> Int -> Int -> Int -> a -> b -> b +parLocal :: Int -> Int -> Int -> Int -> a -> b -> b +parAt :: Int -> Int -> Int -> Int -> a -> b -> c -> c +parAtAbs :: Int -> Int -> Int -> Int -> Int -> a -> b -> b +parAtRel :: Int -> Int -> Int -> Int -> Int -> a -> b -> b +parAtForNow :: Int -> Int -> Int -> Int -> a -> b -> c -> c + +parGlobal (I# w) (I# g) (I# s) (I# p) x y = case (parGlobal# x w g s p y) of { 0# -> parError; _ -> y } +parLocal (I# w) (I# g) (I# s) (I# p) x y = case (parLocal# x w g s p y) of { 0# -> parError; _ -> y } + +parAt (I# w) (I# g) (I# s) (I# p) v x y = case (parAt# x v w g s p y) of { 0# -> parError; _ -> y } +parAtAbs (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtAbs# x q w g s p y) of { 0# -> parError; _ -> y } +parAtRel (I# w) (I# g) (I# s) (I# p) (I# q) x y = case (parAtRel# x q w g s p y) of { 0# -> parError; _ -> y } +parAtForNow (I# w) (I# g) (I# s) (I# p) v x y = case (parAtForNow# x v w g s p y) of { 0# -> parError; _ -> y } + +#endif + +-- Maybe parIO and the like could be added here later. +#ifndef __GLASGOW_HASKELL__ +-- For now, Hugs does not support par properly. +par a b = b +#endif diff --git a/libraries/base/Control/Parallel/Strategies.hs b/libraries/base/Control/Parallel/Strategies.hs new file mode 100644 index 0000000000..cad9aa3bf1 --- /dev/null +++ b/libraries/base/Control/Parallel/Strategies.hs @@ -0,0 +1,964 @@ +----------------------------------------------------------------------------- +-- +-- Module : Control.Parallel.Strategies +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Parallel strategy combinators +-- +----------------------------------------------------------------------------- + +{- +Time-stamp: <Wed Mar 21 2001 00:45:34 Stardate: [-30]6360.15 hwloidl> +$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ + +This module defines parallel strategy combinators + + Phil Trinder, Hans-Wolfgang Loidl, Kevin Hammond et al. + + Based on Version VII (1/5/96) `Strategies96' of type a -> () + +Author: $Author: simonmar $ +Date: $Date: 2001/06/28 14:15:02 $ +Revision: $Revision: 1.1 $ +Source: $Source: /srv/cvs/cvs.haskell.org/fptools/libraries/base/Control/Parallel/Strategies.hs,v $ +State: $State: Exp $ + +This module defines evaluation strategies for controlling the parallel +evaluation of non-strict programs. They provide a clean separation between +algorithmic and behavioural code. + +The functions described here, and their use is documented in + +"Algorithm + Strategy = Parallelism", +P.W. Trinder, K. Hammond, H-W. Loidl, S.L. Peyton Jones +In Journal of Functional Programming 8(1):23--60, January 1998. +URL: http://www.cee.hw.ac.uk/~dsg/gph/papers/ps/strategies.ps.gz + +This module supports Haskell 1.2, Haskell 1.4 and Haskell98. +The distinction is made based on the __HASKELL1__ CPP variable. +Parts of the module could be rewritten using constructor classes. + +----------------------------------------------------------------------------- +The history of the Strategies module: + +Changelog: +$Log: Strategies.hs,v $ +Revision 1.1 2001/06/28 14:15:02 simonmar +First cut of the Haskell Core Libraries +======================================= + +NOTE: it's not meant to be a working snapshot. The code is just here +to look at and so the NHC/Hugs guys can start playing around with it. + +There is no build system. For GHC, the libraries tree is intended to +be grafted onto an existing fptools/ tree, and the Makefile in +libraries/core is a quick hack for that setup. This won't work at the +moment without the other changes needed in fptools/ghc, which I +haven't committed because they'll cause breakage. However, with the +changes required these sources build a working Prelude and libraries. + +The layout mostly follows the one we agreed on, with one or two minor +changes; in particular the Data/Array layout probably isn't final +(there are several choices here). + +The document is in libraries/core/doc as promised. + +The cbits stuff is just a copy of ghc/lib/std/cbits and has +GHC-specific stuff in it. We should really separate the +compiler-specific C support from any compiler-independent C support +there might be. + +Don't pay too much attention to the portability or stability status +indicated in the header of each source file at the moment - I haven't +gone through to make sure they're all consistent and make sense. + +I'm using non-literate source outside of GHC/. Hope that's ok with +everyone. + +We need to discuss how the build system is going to work... + +Revision 1.3 2001/03/22 03:51:12 hwloidl + -*- outline -*- +Time-stamp: <Thu Mar 22 2001 03:50:16 Stardate: [-30]6365.79 hwloidl> + +This commit covers changes in GHC to get GUM (way=mp) and GUM/GdH (way=md) +working. It is a merge of my working version of GUM, based on GHC 4.06, +with GHC 4.11. Almost all changes are in the RTS (see below). + +GUM is reasonably stable, we used the 4.06 version in large-ish programs for +recent papers. Couple of things I want to change, but nothing urgent. +GUM/GdH has just been merged and needs more testing. Hope to do that in the +next weeks. It works in our working build but needs tweaking to run. +GranSim doesn't work yet (*sigh*). Most of the code should be in, but needs +more debugging. + +ToDo: I still want to make the following minor modifications before the release +- Better wrapper skript for parallel execution [ghc/compiler/main] +- Update parallel docu: started on it but it's minimal [ghc/docs/users_guide] +- Clean up [nofib/parallel]: it's a real mess right now (*sigh*) +- Update visualisation tools (minor things only IIRC) [ghc/utils/parallel] +- Add a Klingon-English glossary + +* RTS: + +Almost all changes are restricted to ghc/rts/parallel and should not +interfere with the rest. I only comment on changes outside the parallel +dir: + +- Several changes in Schedule.c (scheduling loop; createThreads etc); + should only affect parallel code +- Added ghc/rts/hooks/ShutdownEachPEHook.c +- ghc/rts/Linker.[ch]: GUM doesn't know about Stable Names (ifdefs)!! +- StgMiscClosures.h: END_TSO_QUEUE etc now defined here (from StgMiscClosures.hc) + END_ECAF_LIST was missing a leading stg_ +- SchedAPI.h: taskStart now defined in here; it's only a wrapper around + scheduleThread now, but might use some init, shutdown later +- RtsAPI.h: I have nuked the def of rts_evalNothing + +* Compiler: + +- ghc/compiler/main/DriverState.hs + added PVM-ish flags to the parallel way + added new ways for parallel ticky profiling and distributed exec + +- ghc/compiler/main/DriverPipeline.hs + added a fct run_phase_MoveBinary which is called with way=mp after linking; + it moves the bin file into a PVM dir and produces a wrapper script for + parallel execution + maybe cleaner to add a MoveBinary phase in DriverPhases.hs but this way + it's less intrusive and MoveBinary makes probably only sense for mp anyway + +* Nofib: + +- nofib/spectral/Makefile, nofib/real/Makefile, ghc/tests/programs/Makefile: + modified to skip some tests if HWL_NOFIB_HACK is set; only tmp to record + which test prgs cause problems in my working build right now + +Revision 1.2 2000/11/18 02:13:11 hwloidl +Now provides explicit def of seq (rather than just re-exporting). +Required by the current version of the compiler. + +Revision 1.1 2000/01/14 13:34:32 hwloidl +Module for specifying (parallel) behavioural code. + +Revision 1.9 1997/10/01 00:27:19 hwloidl +Type of par and seq changed to Done -> Done -> Done with Done = () +Works for Haskell 1.2 as well as Haskell 1.4 (checks the CPP variable +__HASKELL1__ to distinguish setups). +Fixed precedences for par and seq for Haskell 1.4 (stronger than using). +New infix operators >| and >|| as aliases for par and seq as strategy +combinators. + +Revision 1.8 1997/05/20 21:13:22 hwloidl +Revised to use `demanding` and `sparking` (final JFP paper version) + +Revision 1.7 1997/04/02 21:26:21 hwloidl +Minor changes in documentation, none in the code. + + +revision 1.5 +Version VII.1; Strategies96; Type: a -> () +Minor changes to previous version. +CPP flags now separate GUM from GranSim version. +Infix declaration for `using` (important for e.g. quicksort where the old +version puts parentheses in the wrong way). +Moer instances for NFData and markStartegies (in GranSim setup only). + +revision 1.4 +Version VII; Strategies96; Type: a -> () +The type has changed again; with the old type it's not possible to describe +all the strategies we want (for example seqPair r0 rnf which should not +evaluate the first component of the pair at all). The () type acts as info +that the strategy has been applied. +The function `using` is used as inverse strategy application i.e. +on top level we usually have something like res `using` strat where ... +The markStrategy hack is included in this version: it attaches an Int value +to the currently running strategy (this can be inherited by all sub-strats) +It doesn't model the jumps between evaluating producer and consumer properly +(for that something like cost centers would be necessary). + +revision 1.3 +Version VI (V-based); Strategies95; Type: a -> a +Now uses library modules like FiniteMap with strategies in there. +CPP flags for using the same module with GUM and GranSim. +A few new strategies. + +revision 1.2 +Version V; Strategies95; Type: a -> a +The type of Strategies has changed from a -> () to a -> a +All strategies and instances of NFData have been redefined accordingly. +This branch started off after discussions between PWT, SLPJ and HWL in +mid Nov (start of development of the actual module: 10/1/96) + +revision 1.1 Initial revision +----------------------------------------------------------------------------- +-- To use fakeinfo first replace all %%$ by \@ +-- If you have fakeinfo makers in the file you need a slightly modified +-- version of the lit-deatify script (called by lit2pgm). You get that +-- version on Suns and Alphas in Glasgow by using +-- \tr{lit2pgm -H "${HOME}/bin/`hw_os`"} +-- in your Makefile +----------------------------------------------------------------------------- + +--@node Evaluation Strategies, , , +--@chapter Evaluation Strategies + +--@menu +--* Imports and infix declarations:: +--* Strategy Type and Application:: +--* Basic Strategies:: +--* Strategic Function Application:: +--* Marking a Strategy:: +--* Strategy Instances:: +--* Lolita-specific Strategies:: +--@end menu + +--@node Imports and infix declarations, Strategy Type and Application, Evaluation Strategies, Evaluation Strategies +--@section Imports and infix declarations + +> module Strategies( +>#if (__HASKELL1__>=4) +> module Strategies, +> module Parallel +>#else +> Strategies.. +>#endif +> ) where +> +>#if defined(GRAN) && !(__HASKELL1__>=4) +> import PreludeGlaST -- only needed for markStrat +>#endif +>#if (__HASKELL1__>=4) + +<> import Prelude hiding (seq) +<> import qualified Parallel + +> import Parallel + +>#else +> import Parallel renaming (par to par_from_Parallel, seq to seq_from_Parallel) +>#endif + +>#if (__HASKELL1__>=4) +> import Ix +> import Array +>#endif + +>#if defined(PAR_GRAN_LIST) +> import QSort -- tmp (only for parGranList) +>#endif + +I lifted the precedence of @par@ and @seq@ by one level to make @using@ the +combinator with the weakest precedence. +Oooops, there seems to be a bug in ghc 0.29 prohibiting another infix +declaration of @par@ and @seq@ despite renaming the imported versions. + +>#if (__HASKELL1__>=4) + +<> infixr 2 `par` -- was: 0 +<> infixr 3 `seq` -- was: 1 + +>#else +> infixr 0 `par` -- was: 0 +> infixr 1 `seq` -- was: 1 +>#endif + +> infixl 0 `using`,`demanding`,`sparking` -- weakest precedence! + +> infixr 2 >|| -- another name for par +> infixr 3 >| -- another name for seq +> infixl 6 $||, $| -- strategic function application (seq and par) +> infixl 9 .|, .||, -|, -|| -- strategic (inverse) function composition + +> strategy_version = "$Revision: 1.1 $" +> strategy_id = "$Id: Strategies.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $" + +------------------------------------------------------------------------------ + Strategy Type, Application and Semantics +------------------------------------------------------------------------------ +--@node Strategy Type and Application, Basic Strategies, Imports and infix declarations, Evaluation Strategies +--@section Strategy Type and Application + +--@cindex Strategy + +> type Done = () +> type Strategy a = a -> Done + +A strategy takes a value and returns a dummy `done' value to indicate that +the specifed evaluation has been performed. + +The basic combinators for strategies are @par@ and @seq@ but with types that +indicate that they only combine the results of a strategy application. + +NB: This version can be used with Haskell 1.4 (GHC 2.05 and beyond), *but* + you won't get strategy checking on seq (only on par)! + +The infix fcts >| and >|| are alternative names for `seq` and `par`. +With the introduction of a Prelude function `seq` separating the Prelude +function from the Strategy function becomes a pain. The notation also matches +the notation for strategic function application. + +--@cindex par +--@cindex seq +--@cindex >| +--@cindex >|| + +>#if (__HASKELL1__>=4) + +par and seq have the same types as before; >| and >|| are more specific +and can only be used when composing strategies. + +<> par :: Done -> Done -> Done +<> par = Parallel.par +<> seq :: a -> b -> b -- that's the real type of seq defined in Prelude +<> seq = Parallel.seq + +> (>|), (>||) :: Done -> Done -> Done +> {-# INLINE (>|) #-} +> {-# INLINE (>||) #-} +> (>|) = Prelude.seq +> (>||) = Parallel.par +>#else +> par, seq, (>|), (>||) :: Done -> Done -> Done +> par = par_from_Parallel +> seq = seq_from_Parallel +> {-# INLINE (>|) #-} +> {-# INLINE (>||) #-} +> (>|) = seq +> (>||) = par +>#endif + +--@cindex using + +> using :: a -> Strategy a -> a +>#if (__HASKELL1__>=4) +> using x s = s x `seq` x +>#else +> using x s = s x `seq_from_Parallel` x +>#endif + +using takes a strategy and a value, and applies the strategy to the +value before returning the value. Used to express data-oriented parallelism + +x `using` s is a projection on x, i.e. both + + a retraction: x `using` s [ x + - + and idempotent: (x `using` s) `using` s = x `using` s + +demanding and sparking are used to express control-oriented +parallelism. Their second argument is usually a sequence of strategy +applications combined `par` and `seq`. Sparking should only be used +with a singleton sequence as it is not necessarily excuted + +--@cindex demanding +--@cindex sparking + +> demanding, sparking :: a -> Done -> a +>#if (__HASKELL1__>=4) +> demanding = flip Parallel.seq +> sparking = flip Parallel.par +>#else +> demanding = flip seq_from_Parallel +> sparking = flip par_from_Parallel +>#endif + +sPar and sSeq have been superceded by sparking and demanding: replace + e `using` sPar x with e `sparking` x + e `using` sSeq x with e `demanding` x + +<sPar is a strategy corresponding to par. i.e. x `par` e <=> e `using` sPar x +< +<> sPar :: a -> Strategy b +<> sPar x y = x `par` () +< +<sSeq is a strategy corresponding to seq. i.e. x `seq` e <=> e `using` sSeq x +< +<> sSeq :: a -> Strategy b +<> sSeq x y = x `seq` () + +----------------------------------------------------------------------------- + Basic Strategies +----------------------------------------------------------------------------- +--@node Basic Strategies, Strategic Function Application, Strategy Type and Application, Evaluation Strategies +--@section Basic Strategies + +r0 performs *no* evaluation on its argument. + +--@cindex r0 + +> r0 :: Strategy a +> r0 x = () + +rwhnf reduces its argument to weak head normal form. + +--@cindex rwhnf +--@cindex rnf +--@cindex NFData + +>#if defined(__HASKELL98__) +> rwhnf :: Strategy a +> rwhnf x = x `seq` () +>#elif (__HASKELL1__==4) +> rwhnf :: Eval a => Strategy a +> rwhnf x = x `seq` () +>#else +> rwhnf :: Strategy a +> rwhnf x = x `seq_from_Parallel` () +>#endif + +>#if defined(__HASKELL98__) +> class NFData a where +>#elif (__HASKELL1__>=4) +> class Eval a => NFData a where +>#else +> class NFData a where +>#endif +> -- rnf reduces its argument to (head) normal form +> rnf :: Strategy a +> -- Default method. Useful for base types. A specific method is necessay for +> -- constructed types +> rnf = rwhnf +> +> class (NFData a, Integral a) => NFDataIntegral a +> class (NFData a, Ord a) => NFDataOrd a + +------------------------------------------------------------------------------ + Strategic Function Application +------------------------------------------------------------------------------ +--@node Strategic Function Application, Marking a Strategy, Basic Strategies, Evaluation Strategies +--@section Strategic Function Application + +The two infix functions @$|@ and @$||@ perform sequential and parallel +function application, respectively. They are parameterised with a strategy +that is applied to the argument of the function application. This is very +handy when writing pipeline parallelism as a sequence of @$@, @$|@ and +@$||@'s. There is no need of naming intermediate values in this case. The +separation of algorithm from strategy is achieved by allowing strategies +only as second arguments to @$|@ and @$||@. + +--@cindex $| +--@cindex $|| + +> ($|), ($||) :: (a -> b) -> Strategy a -> a -> b + +<> f $| s = \ x -> f x `using` \ _ -> s x `seq` () +<> f $|| s = \ x -> f x `using` \ _ -> s x `par` () + +> f $| s = \ x -> f x `demanding` s x +> f $|| s = \ x -> f x `sparking` s x + +The same thing for function composition (.| and .||) and inverse function +composition (-| and -||) for those who read their programs from left to +right. + +--@cindex .| +--@cindex .|| +--@cindex -| +--@cindex -|| + +> (.|), (.||) :: (b -> c) -> Strategy b -> (a -> b) -> (a -> c) +> (-|), (-||) :: (a -> b) -> Strategy b -> (b -> c) -> (a -> c) + +> (.|) f s g = \ x -> let gx = g x +> in f gx `demanding` s gx +> (.||) f s g = \ x -> let gx = g x +> in f gx `sparking` s gx + +> (-|) f s g = \ x -> let fx = f x +> in g fx `demanding` s fx +> (-||) f s g = \ x -> let fx = f x +> in g fx `sparking` s fx + +------------------------------------------------------------------------------ + Marking a Strategy +------------------------------------------------------------------------------ +--@node Marking a Strategy, Strategy Instances, Strategic Function Application, Evaluation Strategies +--@section Marking a Strategy + +Marking a strategy. + +Actually, @markStrat@ sticks a label @n@ into the sparkname field of the +thread executing strategy @s@. Together with a runtime-system that supports +propagation of sparknames to the children this means that this strategy and +all its children have the sparkname @n@ (if the static sparkname field in +the @parGlobal@ annotation contains the value 1). Note, that the @SN@ field +of starting the marked strategy itself contains the sparkname of the parent +thread. The END event contains @n@ as sparkname. + +--@cindex markStrat + +>#if defined(GRAN) && !(__HASKELL1__>=4) +> markStrat :: Int -> Strategy a -> Strategy a +> markStrat n s x = unsafePerformPrimIO ( +> _casm_ ``%r = set_sparkname(CurrentTSO, %0);'' n `thenPrimIO` \ z -> +> returnPrimIO (s x)) +>#endif + +----------------------------------------------------------------------------- + Strategy Instances and Functions +----------------------------------------------------------------------------- +--@node Strategy Instances, Lolita-specific Strategies, Marking a Strategy, Evaluation Strategies +--@section Strategy Instances +----------------------------------------------------------------------------- + Tuples +----------------------------------------------------------------------------- +--@menu +--* Tuples:: +--* Numbers:: +--* Characters:: +--* Booleans:: +--* Unit:: +--* Lists:: +--* Arrays:: +--@end menu + +--@node Tuples, Numbers, Strategy Instances, Strategy Instances +--@subsection Tuples + +We currently support up to 9-tuples. If you need longer tuples you have to +add the instance explicitly to your program. + +> instance (NFData a, NFData b) => NFData (a,b) where +> rnf (x,y) = rnf x `seq` rnf y + +> instance (NFData a, NFData b, NFData c) => NFData (a,b,c) where +> rnf (x,y,z) = rnf x `seq` rnf y `seq` rnf z + +> instance (NFData a, NFData b, NFData c, NFData d) => NFData (a,b,c,d) where +> rnf (x1,x2,x3,x4) = rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 + +> -- code automatically inserted by `hwl-insert-NFData-n-tuple' +> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5) => +> NFData (a1, a2, a3, a4, a5) where +> rnf (x1, x2, x3, x4, x5) = +> rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 `seq` +> rnf x5 + +> -- code automatically inserted by `hwl-insert-NFData-n-tuple' +> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6) => +> NFData (a1, a2, a3, a4, a5, a6) where +> rnf (x1, x2, x3, x4, x5, x6) = +> rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 `seq` +> rnf x5 `seq` +> rnf x6 + +> -- code automatically inserted by `hwl-insert-NFData-n-tuple' +> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7) => +> NFData (a1, a2, a3, a4, a5, a6, a7) where +> rnf (x1, x2, x3, x4, x5, x6, x7) = +> rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 `seq` +> rnf x5 `seq` +> rnf x6 `seq` +> rnf x7 + +> -- code automatically inserted by `hwl-insert-NFData-n-tuple' +> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8) => +> NFData (a1, a2, a3, a4, a5, a6, a7, a8) where +> rnf (x1, x2, x3, x4, x5, x6, x7, x8) = +> rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 `seq` +> rnf x5 `seq` +> rnf x6 `seq` +> rnf x7 `seq` +> rnf x8 + +> -- code automatically inserted by `hwl-insert-NFData-n-tuple' +> instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9) => +> NFData (a1, a2, a3, a4, a5, a6, a7, a8, a9) where +> rnf (x1, x2, x3, x4, x5, x6, x7, x8, x9) = +> rnf x1 `seq` +> rnf x2 `seq` +> rnf x3 `seq` +> rnf x4 `seq` +> rnf x5 `seq` +> rnf x6 `seq` +> rnf x7 `seq` +> rnf x8 `seq` +> rnf x9 + +--@cindex seqPair + +> seqPair :: Strategy a -> Strategy b -> Strategy (a,b) +> seqPair strata stratb (x,y) = strata x `seq` stratb y + +--@cindex parPair + +> parPair :: Strategy a -> Strategy b -> Strategy (a,b) +> parPair strata stratb (x,y) = strata x `par` stratb y `par` () + +The reason for the second `par` is so that the strategy terminates +quickly. This is important if the strategy is used as the 1st argument of a seq + +--@cindex seqTriple + +> seqTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c) +> seqTriple strata stratb stratc p@(x,y,z) = +> strata x `seq` +> stratb y `seq` +> stratc z + +--@cindex parTriple + +> parTriple :: Strategy a -> Strategy b -> Strategy c -> Strategy (a,b,c) +> parTriple strata stratb stratc (x,y,z) = +> strata x `par` +> stratb y `par` +> stratc z `par` +> () + +----------------------------------------------------------------------------- + Numbers +----------------------------------------------------------------------------- +--@node Numbers, Characters, Tuples, Strategy Instances +--@subsection Numbers + +Weak head normal form and normal form are identical for integers, so the +default rnf is sufficient. + +> instance NFData Int +> instance NFData Integer +> instance NFData Float +> instance NFData Double + +> instance NFDataIntegral Int +> instance NFDataOrd Int + +Rational and complex numbers. + +>#if !(__HASKELL1__>=4) +> instance (NFData a) => NFData (Ratio a) where +> rnf (x:%y) = rnf x `seq` +> rnf y `seq` +> () + +> instance (NFData a) => NFData (Complex a) where +> rnf (x:+y) = rnf x `seq` +> rnf y `seq` +> () +>#endif + +----------------------------------------------------------------------------- + Characters +----------------------------------------------------------------------------- +--@node Characters, Booleans, Numbers, Strategy Instances +--@subsection Characters + +> instance NFData Char + +----------------------------------------------------------------------------- + Bools +----------------------------------------------------------------------------- +--@node Booleans, Unit, Characters, Strategy Instances +--@subsection Booleans + +> instance NFData Bool + +----------------------------------------------------------------------------- + Unit +----------------------------------------------------------------------------- +--@node Unit, Lists, Booleans, Strategy Instances +--@subsection Unit + +> instance NFData () + +----------------------------------------------------------------------------- + Lists +---------------------------------------------------------------------------- +--@node Lists, Arrays, Unit, Strategy Instances +--@subsection Lists + +> instance NFData a => NFData [a] where +> rnf [] = () +> rnf (x:xs) = rnf x `seq` rnf xs + +--@menu +--* Parallel Strategies for Lists:: +--* Sequential Strategies for Lists:: +--@end menu + +---------------------------------------------------------------------------- + Lists: Parallel Strategies +---------------------------------------------------------------------------- +--@node Parallel Strategies for Lists, Sequential Strategies for Lists, Lists, Lists +--@subsubsection Parallel Strategies for Lists + +Applies a strategy to every element of a list in parallel + +--@cindex parList + +> parList :: Strategy a -> Strategy [a] +> parList strat [] = () +> parList strat (x:xs) = strat x `par` (parList strat xs) + +Applies a strategy to the first n elements of a list in parallel + +--@cindex parListN + +> parListN :: (Integral b) => b -> Strategy a -> Strategy [a] +> parListN n strat [] = () +> parListN 0 strat xs = () +> parListN n strat (x:xs) = strat x `par` (parListN (n-1) strat xs) + +Evaluates N elements of the spine of the argument list and applies +`strat' to the Nth element (if there is one) in parallel with the +result. e.g. parListNth 2 [e1, e2, e3] evaluates e2 + +--@cindex parListNth + +> parListNth :: Int -> Strategy a -> Strategy [a] +> parListNth n strat xs +> | null rest = () +> | otherwise = strat (head rest) `par` () +> where +> rest = drop n xs + +parListChunk sequentially applies a strategy to chunks +(sub-sequences) of a list in parallel. Useful to increase grain size + +--@cindex parListChunk + +> parListChunk :: Int -> Strategy a -> Strategy [a] +> parListChunk n strat [] = () +> parListChunk n strat xs = seqListN n strat xs `par` +> parListChunk n strat (drop n xs) + +parMap applies a function to each element of the argument list in +parallel. The result of the function is evaluated using `strat' + +--@cindex parMap + +> parMap :: Strategy b -> (a -> b) -> [a] -> [b] +> parMap strat f xs = map f xs `using` parList strat + +parFlatMap uses parMap to apply a list-valued function to each +element of the argument list in parallel. The result of the function +is evaluated using `strat' + +--@cindex parFlatMap + +> parFlatMap :: Strategy [b] -> (a -> [b]) -> [a] -> [b] +> parFlatMap strat f xs = concat (parMap strat f xs) + +parZipWith zips together two lists with a function z in parallel + +--@cindex parZipWith + +> parZipWith :: Strategy c -> (a -> b -> c) -> [a] -> [b] -> [c] +> parZipWith strat z as bs = +> zipWith z as bs `using` parList strat + +---------------------------------------------------------------------------- + Lists: Sequential Strategies +---------------------------------------------------------------------------- +--@node Sequential Strategies for Lists, , Parallel Strategies for Lists, Lists +--@subsubsection Sequential Strategies for Lists + +Sequentially applies a strategy to each element of a list + +--@cindex seqList + +> seqList :: Strategy a -> Strategy [a] +> seqList strat [] = () +> seqList strat (x:xs) = strat x `seq` (seqList strat xs) + +Sequentially applies a strategy to the first n elements of a list + +--@cindex seqListN + +> seqListN :: (Integral a) => a -> Strategy b -> Strategy [b] +> seqListN n strat [] = () +> seqListN 0 strat xs = () +> seqListN n strat (x:xs) = strat x `seq` (seqListN (n-1) strat xs) + +seqListNth applies a strategy to the Nth element of it's argument +(if there is one) before returning the result. e.g. seqListNth 2 [e1, +e2, e3] evaluates e2 + +--@cindex seqListNth + +>#if (__HASKELL1__>=4) +> seqListNth :: Int -> Strategy b -> Strategy [b] +>#else +> seqListNth :: (Integral a) => a -> Strategy b -> Strategy [b] +>#endif +> seqListNth n strat xs +> | null rest = () +> | otherwise = strat (head rest) +> where +> rest = drop n xs + +Parallel n-buffer function added for the revised version of the strategies +paper. @parBuffer@ supersedes the older @fringeList@. It has the same +semantics. + +--@cindex parBuffer + +> parBuffer :: Int -> Strategy a -> [a] -> [a] +> parBuffer n s xs = +> return xs (start n xs) +> where +> return (x:xs) (y:ys) = (x:return xs ys) `sparking` s y +> return xs [] = xs +> +> start n [] = [] +> start 0 ys = ys +> start n (y:ys) = start (n-1) ys `sparking` s y + +fringeList implements a `rolling buffer' of length n, i.e.applies a +strategy to the nth element of list when the head is demanded. More +precisely: + + semantics: fringeList n s = id :: [b] -> [b] + dynamic behaviour: evalutates the nth element of the list when the + head is demanded. + +The idea is to provide a `rolling buffer' of length n. + +--@cindex fringeList + +<> fringeList :: (Integral a) => a -> Strategy b -> [b] -> [b] +<> fringeList n strat [] = [] +<> fringeList n strat (r:rs) = +<> seqListNth n strat rs `par` +<> r:fringeList n strat rs + +------------------------------------------------------------------------------ + Arrays +------------------------------------------------------------------------------ +--@node Arrays, , Lists, Strategy Instances +--@subsection Arrays + +> instance (Ix a, NFData a, NFData b) => NFData (Array a b) where +> rnf x = rnf (bounds x) `seq` seqList rnf (elems x) `seq` () + +Apply a strategy to all elements of an array in parallel. This can be done +either in sequentially or in parallel (same as with lists, really). + +> seqArr :: (Ix b) => Strategy a -> Strategy (Array b a) +> seqArr s arr = seqList s (elems arr) + +> parArr :: (Ix b) => Strategy a -> Strategy (Array b a) +> parArr s arr = parList s (elems arr) + +Associations maybe useful even withou mentioning Arrays. + +See: .../lib/prelude/TyArrays.hs: +data Assoc a b = a := b deriving () + +>#if (__HASKELL1__<4) +> instance (NFData a, NFData b) => NFData (Assoc a b) where +> rnf (x := y) = rnf x `seq` rnf y `seq` () +>#endif + +------------------------------------------------------------------------------ + Some strategies specific for Lolita +------------------------------------------------------------------------------ +--@node Lolita-specific Strategies, Index, Strategy Instances, Evaluation Strategies +--@section Lolita-specific Strategies + +The following is useful in mergePenGroups + +--@cindex fstPairFstList + +> fstPairFstList :: (NFData a) => Strategy [(a,b)] +> fstPairFstList = seqListN 1 (seqPair rwhnf r0) + +Some HACKs for Lolita. AFAIK force is just another name for our rnf and +sforce is a shortcut (definition here is identical to the one in Force.lhs) + +> force :: (NFData a) => a -> a +> sforce :: (NFData a) => a -> b -> b + +Same as definition below + +<> force x = rnf x `seq` x + +> force = id $| rnf +>#if (__HASKELL1__>=4) +> sforce x y = force x `seq` y +>#else +> sforce x y = force x `seq_from_Parallel` y +>#endif + +--@node Bowing-alg specific strategies +--@section Bowing-alg specific strategies + +NB: this strategy currently needs the quicksort implementation from the hbc syslib + +>#if defined(PAR_GRAN_LIST) +> parGranList :: Strategy a -> (a -> Int) -> [a] -> Strategy [a] +> parGranList s gran_estim l_in = \ l_out -> +> parListByIdx s l_out $ +> sortedIdx gran_list (sortLe ( \ (i,_) (j,_) -> i>j) gran_list) +> where -- spark list elems of l in the order specified by (i:idxs) +> parListByIdx s l [] = () +> parListByIdx s l (i:idxs) = parListByIdx s l idxs `sparking` s (l!!i) +> -- get the index of y in the list +> idx y [] = error "idx: x not in l" +> idx y ((x,_):xs) | y==x = 0 +> | otherwise = (idx y xs)+1 +> -- the `schedule' for sparking: list of indices of sorted input list +> sortedIdx l idxs = [ idx x l | (x,_) <- idxs ] +> -- add granularity info to elems of the input list +> gran_list = map (\ l -> (gran_estim l, l)) l_in +>#endif + +--@node Index, , Lolita-specific Strategies, Evaluation Strategies +--@section Index + +--@index +--* $|:: @cindex\s-+$| +--* $||:: @cindex\s-+$|| +--* -|:: @cindex\s-+-| +--* -||:: @cindex\s-+-|| +--* .|:: @cindex\s-+.| +--* .||:: @cindex\s-+.|| +--* NFData:: @cindex\s-+NFData +--* Strategy:: @cindex\s-+Strategy +--* demanding:: @cindex\s-+demanding +--* fringeList:: @cindex\s-+fringeList +--* fstPairFstList:: @cindex\s-+fstPairFstList +--* markStrat:: @cindex\s-+markStrat +--* parBuffer:: @cindex\s-+parBuffer +--* parFlatMap:: @cindex\s-+parFlatMap +--* parList:: @cindex\s-+parList +--* parListChunk:: @cindex\s-+parListChunk +--* parListN:: @cindex\s-+parListN +--* parListNth:: @cindex\s-+parListNth +--* parMap:: @cindex\s-+parMap +--* parPair:: @cindex\s-+parPair +--* parTriple:: @cindex\s-+parTriple +--* parZipWith:: @cindex\s-+parZipWith +--* r0:: @cindex\s-+r0 +--* rnf:: @cindex\s-+rnf +--* rwhnf:: @cindex\s-+rwhnf +--* seqList:: @cindex\s-+seqList +--* seqListN:: @cindex\s-+seqListN +--* seqListNth:: @cindex\s-+seqListNth +--* seqPair:: @cindex\s-+seqPair +--* seqTriple:: @cindex\s-+seqTriple +--* sparking:: @cindex\s-+sparking +--* using:: @cindex\s-+using +--@end index diff --git a/libraries/base/Data/Array.hs b/libraries/base/Data/Array.hs new file mode 100644 index 0000000000..c13cc91387 --- /dev/null +++ b/libraries/base/Data/Array.hs @@ -0,0 +1,145 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Array +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Array.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Basic non-strict arrays. +-- +----------------------------------------------------------------------------- + +module Data.Array + + ( + module Data.Ix -- export all of Ix + , Array -- Array type is abstract + + , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b + , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b + , (!) -- :: (Ix a) => Array a b -> a -> b + , bounds -- :: (Ix a) => Array a b -> (a,a) + , indices -- :: (Ix a) => Array a b -> [a] + , elems -- :: (Ix a) => Array a b -> [b] + , assocs -- :: (Ix a) => Array a b -> [(a,b)] + , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b + , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b + , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b + , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b + + -- Array instances: + -- + -- Ix a => Functor (Array a) + -- (Ix a, Eq b) => Eq (Array a b) + -- (Ix a, Ord b) => Ord (Array a b) + -- (Ix a, Show a, Show b) => Show (Array a b) + -- (Ix a, Read a, Read b) => Read (Array a b) + -- + + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + + ) where + +import Data.Dynamic + +#ifdef __GLASGOW_HASKELL__ +import Data.Ix +import GHC.Arr -- Most of the hard work is done here +import GHC.Err ( undefined ) +#endif + +#include "Dynamic.h" +INSTANCE_TYPEABLE2(Array,arrayTc,"Array") + +#ifdef __HUGS__ + ------------ HUGS (rest of file) -------------------- +import PrelPrim ( PrimArray + , runST + , primNewArray + , primWriteArray + , primReadArray + , primUnsafeFreezeArray + , primIndexArray + ) +import Ix +import List( (\\) ) + +infixl 9 !, // + +-- ----------------------------------------------------------------------------- +-- The Array type + +data Array ix elt = Array (ix,ix) (PrimArray elt) + +array :: Ix a => (a,a) -> [(a,b)] -> Array a b +array ixs@(ix_start, ix_end) ivs = runST (do + { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom + ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs + ; arr <- primUnsafeFreezeArray mut_arr + ; return (Array ixs arr) + } + ) + where + arrEleBottom = error "(Array.!): undefined array element" + +listArray :: Ix a => (a,a) -> [b] -> Array a b +listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) + +(!) :: Ix a => Array a b -> a -> b +(Array bounds arr) ! i = primIndexArray arr (index bounds i) + +bounds :: Ix a => Array a b -> (a,a) +bounds (Array b _) = b + +indices :: Ix a => Array a b -> [a] +indices = range . bounds + +elems :: Ix a => Array a b -> [b] +elems a = [a!i | i <- indices a] + +assocs :: Ix a => Array a b -> [(a,b)] +assocs a = [(i, a!i) | i <- indices a] + +(//) :: Ix a => Array a b -> [(a,b)] -> Array a b +(//) a us = array (bounds a) + ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]] + ++ us) + +accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b +accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)]) + +accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +accumArray f z b = accum f (array b [(i,z) | i <- range b]) + +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c +ixmap b f a = array b [(i, a ! f i) | i <- range b] + + +instance (Ix a) => Functor (Array a) where + fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a] + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + a <= a' = assocs a <= assocs a' + + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) +#endif /* __HUGS__ */ diff --git a/libraries/base/Data/Array/Base.hs b/libraries/base/Data/Array/Base.hs new file mode 100644 index 0000000000..7821876159 --- /dev/null +++ b/libraries/base/Data/Array/Base.hs @@ -0,0 +1,1163 @@ +{-# OPTIONS -monly-3-regs #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.Base +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Base.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Basis for IArray and MArray. Not intended for external consumption; +-- use IArray or MArray instead. +-- +----------------------------------------------------------------------------- + +module Data.Array.Base where + +import Prelude + +import Data.Ix ( Ix, range, index, rangeSize ) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr ( STArray, unsafeIndex ) +import qualified GHC.Arr +import GHC.ST ( ST(..), runST ) +import GHC.Base +import GHC.Word ( Word(..) ) +import GHC.Ptr ( Ptr(..), FunPtr(..) ) +import GHC.Float ( Float(..), Double(..) ) +import GHC.Stable ( StablePtr(..) ) +import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) +import GHC.Word ( Word8(..), Word16(..), Word32(..), Word64(..) ) +#endif + +import Data.Dynamic +#include "Dynamic.h" + +----------------------------------------------------------------------------- +-- Class of immutable arrays + +class HasBounds a where + bounds :: Ix i => a i e -> (i,i) + +class HasBounds a => IArray a e where + unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> a i e + unsafeAt :: Ix i => a i e -> Int -> e + unsafeReplace :: Ix i => a i e -> [(Int, e)] -> a i e + unsafeAccum :: Ix i => (e -> e' -> e) -> a i e -> [(Int, e')] -> a i e + unsafeAccumArray :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> a i e + + unsafeReplace arr ies = runST (unsafeReplaceST arr ies >>= unsafeFreeze) + unsafeAccum f arr ies = runST (unsafeAccumST f arr ies >>= unsafeFreeze) + unsafeAccumArray f e lu ies = runST (unsafeAccumArrayST f e lu ies >>= unsafeFreeze) + +{-# INLINE unsafeReplaceST #-} +unsafeReplaceST :: (IArray a e, Ix i) => a i e -> [(Int, e)] -> ST s (STArray s i e) +unsafeReplaceST arr ies = do + marr <- thaw arr + sequence_ [unsafeWrite marr i e | (i, e) <- ies] + return marr + +{-# INLINE unsafeAccumST #-} +unsafeAccumST :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(Int, e')] -> ST s (STArray s i e) +unsafeAccumST f arr ies = do + marr <- thaw arr + sequence_ [do + old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + return marr + +{-# INLINE unsafeAccumArrayST #-} +unsafeAccumArrayST :: Ix i => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (STArray s i e) +unsafeAccumArrayST f e (l,u) ies = do + marr <- newArray (l,u) e + sequence_ [do + old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + return marr + +{-# INLINE array #-} +array :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e +array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies] + +-- Since unsafeFreeze is not guaranteed to be only a cast, we will +-- use unsafeArray and zip instead of a specialized loop to implement +-- listArray, unlike Array.listArray, even though it generates some +-- unnecessary heap allocation. Will use the loop only when we have +-- fast unsafeFreeze, namely for Array and UArray (well, they cover +-- almost all cases). + +{-# INLINE listArray #-} +listArray :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e +listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es) + +{-# INLINE listArrayST #-} +listArrayST :: Ix i => (i,i) -> [e] -> ST s (STArray s i e) +listArrayST (l,u) es = do + marr <- newArray_ (l,u) + let n = rangeSize (l,u) + let fillFromList i xs | i == n = return () + | otherwise = case xs of + [] -> return () + y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys + fillFromList 0 es + return marr + +{-# RULES +"listArray/Array" listArray = + \lu es -> runST (listArrayST lu es >>= GHC.Arr.unsafeFreezeSTArray) + #-} + +{-# INLINE listUArrayST #-} +listUArrayST :: (MArray (STUArray s) e (ST s), Ix i) + => (i,i) -> [e] -> ST s (STUArray s i e) +listUArrayST (l,u) es = do + marr <- newArray_ (l,u) + let n = rangeSize (l,u) + let fillFromList i xs | i == n = return () + | otherwise = case xs of + [] -> return () + y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys + fillFromList 0 es + return marr + +-- I don't know how to write a single rule for listUArrayST, because +-- the type looks like constrained over 's', which runST doesn't +-- like. In fact all MArray (STUArray s) instances are polymorphic +-- wrt. 's', but runST can't know that. + +-- I would like to write a rule for listUArrayST (or listArray or +-- whatever) applied to unpackCString#. Unfortunately unpackCString# +-- calls seem to be floated out, then floated back into the middle +-- of listUArrayST, so I was not able to do this. + +{-# RULES +"listArray/UArray/Bool" listArray = \lu (es :: [Bool]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Char" listArray = \lu (es :: [Char]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Int" listArray = \lu (es :: [Int]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Word" listArray = \lu (es :: [Word]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Ptr" listArray = \lu (es :: [Ptr a]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/FunPtr" listArray = \lu (es :: [FunPtr a]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Float" listArray = \lu (es :: [Float]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Double" listArray = \lu (es :: [Double]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/StablePtr" listArray = \lu (es :: [StablePtr a]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Int8" listArray = \lu (es :: [Int8]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Int16" listArray = \lu (es :: [Int16]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Int32" listArray = \lu (es :: [Int32]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Int64" listArray = \lu (es :: [Int64]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Word8" listArray = \lu (es :: [Word8]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Word16" listArray = \lu (es :: [Word16]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Word32" listArray = \lu (es :: [Word32]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) +"listArray/UArray/Word64" listArray = \lu (es :: [Word64]) -> + runST (listUArrayST lu es >>= unsafeFreezeSTUArray) + #-} + +{-# INLINE (!) #-} +(!) :: (IArray a e, Ix i) => a i e -> i -> e +arr ! i | (l,u) <- bounds arr = unsafeAt arr (index (l,u) i) + +{-# INLINE indices #-} +indices :: (HasBounds a, Ix i) => a i e -> [i] +indices arr | (l,u) <- bounds arr = range (l,u) + +{-# INLINE elems #-} +elems :: (IArray a e, Ix i) => a i e -> [e] +elems arr | (l,u) <- bounds arr = + [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]] + +{-# INLINE assocs #-} +assocs :: (IArray a e, Ix i) => a i e -> [(i, e)] +assocs arr | (l,u) <- bounds arr = + [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)] + +{-# INLINE accumArray #-} +accumArray :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e +accumArray f init (l,u) ies = + unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE (//) #-} +(//) :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e +arr // ies | (l,u) <- bounds arr = + unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE accum #-} +accum :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e +accum f arr ies | (l,u) <- bounds arr = + unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies] + +{-# INLINE amap #-} +amap :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e +amap f arr | (l,u) <- bounds arr = + unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]] + +{-# INLINE ixmap #-} +ixmap :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e +ixmap (l,u) f arr = + unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)] + +----------------------------------------------------------------------------- +-- Normal polymorphic arrays + +instance HasBounds GHC.Arr.Array where + {-# INLINE bounds #-} + bounds = GHC.Arr.bounds + +instance IArray GHC.Arr.Array e where + {-# INLINE unsafeArray #-} + unsafeArray = GHC.Arr.unsafeArray + {-# INLINE unsafeAt #-} + unsafeAt = GHC.Arr.unsafeAt + {-# INLINE unsafeReplace #-} + unsafeReplace = GHC.Arr.unsafeReplace + {-# INLINE unsafeAccum #-} + unsafeAccum = GHC.Arr.unsafeAccum + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray = GHC.Arr.unsafeAccumArray + +----------------------------------------------------------------------------- +-- Flat unboxed arrays + +data UArray i e = UArray !i !i ByteArray# + +INSTANCE_TYPEABLE2(UArray,uArrayTc,"UArray") + +instance HasBounds UArray where + {-# INLINE bounds #-} + bounds (UArray l u _) = (l,u) + +{-# INLINE unsafeArrayUArray #-} +unsafeArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) + => (i,i) -> [(Int, e)] -> ST s (UArray i e) +unsafeArrayUArray (l,u) ies = do + marr <- newArray_ (l,u) + sequence_ [unsafeWrite marr i e | (i, e) <- ies] + unsafeFreezeSTUArray marr + +{-# INLINE unsafeFreezeSTUArray #-} +unsafeFreezeSTUArray :: STUArray s i e -> ST s (UArray i e) +unsafeFreezeSTUArray (STUArray l u marr#) = ST $ \s1# -> + case unsafeFreezeByteArray# marr# s1# of { (# s2#, arr# #) -> + (# s2#, UArray l u arr# #) } + +{-# INLINE unsafeReplaceUArray #-} +unsafeReplaceUArray :: (MArray (STUArray s) e (ST s), Ix i) + => UArray i e -> [(Int, e)] -> ST s (UArray i e) +unsafeReplaceUArray arr ies = do + marr <- thawSTUArray arr + sequence_ [unsafeWrite marr i e | (i, e) <- ies] + unsafeFreezeSTUArray marr + +{-# INLINE unsafeAccumUArray #-} +unsafeAccumUArray :: (MArray (STUArray s) e (ST s), Ix i) + => (e -> e' -> e) -> UArray i e -> [(Int, e')] -> ST s (UArray i e) +unsafeAccumUArray f arr ies = do + marr <- thawSTUArray arr + sequence_ [do + old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + unsafeFreezeSTUArray marr + +{-# INLINE unsafeAccumArrayUArray #-} +unsafeAccumArrayUArray :: (MArray (STUArray s) e (ST s), Ix i) + => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')] -> ST s (UArray i e) +unsafeAccumArrayUArray f init (l,u) ies = do + marr <- newArray (l,u) init + sequence_ [do + old <- unsafeRead marr i + unsafeWrite marr i (f old new) + | (i, new) <- ies] + unsafeFreezeSTUArray marr + +{-# INLINE eqUArray #-} +eqUArray :: (IArray UArray e, Ix i, Eq e) => UArray i e -> UArray i e -> Bool +eqUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) = + if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else + l1 == l2 && u1 == u2 && + and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]] + +{-# INLINE cmpUArray #-} +cmpUArray :: (IArray UArray e, Ix i, Ord e) => UArray i e -> UArray i e -> Ordering +cmpUArray arr1 arr2 = compare (assocs arr1) (assocs arr2) + +{-# INLINE cmpIntUArray #-} +cmpIntUArray :: (IArray UArray e, Ord e) => UArray Int e -> UArray Int e -> Ordering +cmpIntUArray arr1@(UArray l1 u1 _) arr2@(UArray l2 u2 _) = + if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else + if rangeSize (l2,u2) == 0 then GT else + case compare l1 l2 of + EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1] + other -> other + where + cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of + EQ -> rest + other -> other + +{-# RULES "cmpUArray/Int" cmpUArray = cmpIntUArray #-} + +showsUArray :: (IArray UArray e, Ix i, Show i, Show e) + => Int -> UArray i e -> ShowS +showsUArray p a = + showParen (p > 9) $ + showString "array " . + shows (bounds a) . + showChar ' ' . + shows (assocs a) + +----------------------------------------------------------------------------- +-- Flat unboxed arrays: instances + +instance IArray UArray Bool where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = + (indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#) + `neWord#` int2Word# 0# + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Char where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = C# (indexWideCharArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Int where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = I# (indexIntArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Word where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = W# (indexWordArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray (Ptr a) where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = Ptr (indexAddrArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray (FunPtr a) where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = FunPtr (indexAddrArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Float where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = F# (indexFloatArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Double where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = D# (indexDoubleArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray (StablePtr a) where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = StablePtr (indexStablePtrArray# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Int8 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = I8# (indexInt8Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Int16 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = I16# (indexInt16Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Int32 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = I32# (indexInt32Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Int64 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = I64# (indexInt64Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Word8 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = W8# (indexWord8Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Word16 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = W16# (indexWord16Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Word32 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = W32# (indexWord32Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance IArray UArray Word64 where + {-# INLINE unsafeArray #-} + unsafeArray lu ies = runST (unsafeArrayUArray lu ies) + {-# INLINE unsafeAt #-} + unsafeAt (UArray _ _ arr#) (I# i#) = W64# (indexWord64Array# arr# i#) + {-# INLINE unsafeReplace #-} + unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies) + {-# INLINE unsafeAccum #-} + unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies) + {-# INLINE unsafeAccumArray #-} + unsafeAccumArray f init lu ies = runST (unsafeAccumArrayUArray f init lu ies) + +instance Ix ix => Eq (UArray ix Bool) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Char) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Int) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Word) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix (Ptr a)) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix (FunPtr a)) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Float) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Double) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix (StablePtr a)) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Int8) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Int16) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Int32) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Int64) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Word8) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Word16) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Word32) where + (==) = eqUArray + +instance Ix ix => Eq (UArray ix Word64) where + (==) = eqUArray + +instance Ix ix => Ord (UArray ix Bool) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Char) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Int) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Word) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix (Ptr a)) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix (FunPtr a)) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Float) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Double) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Int8) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Int16) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Int32) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Int64) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Word8) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Word16) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Word32) where + compare = cmpUArray + +instance Ix ix => Ord (UArray ix Word64) where + compare = cmpUArray + +instance (Ix ix, Show ix) => Show (UArray ix Bool) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Char) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Int) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Word) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Float) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Double) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Int8) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Int16) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Int32) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Int64) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Word8) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Word16) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Word32) where + showsPrec = showsUArray + +instance (Ix ix, Show ix) => Show (UArray ix Word64) where + showsPrec = showsUArray + +----------------------------------------------------------------------------- +-- Mutable arrays + +{-# NOINLINE arrEleBottom #-} +arrEleBottom :: a +arrEleBottom = error "MArray: undefined array element" + +class (HasBounds a, Monad m) => MArray a e m where + newArray :: Ix i => (i,i) -> e -> m (a i e) + newArray_ :: Ix i => (i,i) -> m (a i e) + unsafeRead :: Ix i => a i e -> Int -> m e + unsafeWrite :: Ix i => a i e -> Int -> e -> m () + + newArray (l,u) init = do + marr <- newArray_ (l,u) + sequence_ [unsafeWrite marr i init | i <- [0 .. rangeSize (l,u) - 1]] + return marr + + newArray_ (l,u) = newArray (l,u) arrEleBottom + + -- newArray takes an initialiser which all elements of + -- the newly created array are initialised to. newArray_ takes + -- no initialiser, it is assumed that the array is initialised with + -- "undefined" values. + + -- why not omit newArray_? Because in the unboxed array case we would + -- like to omit the initialisation altogether if possible. We can't do + -- this for boxed arrays, because the elements must all have valid values + -- at all times in case of garbage collection. + + -- why not omit newArray? Because in the boxed case, we can omit the + -- default initialisation with undefined values if we *do* know the + -- initial value and it is constant for all elements. + +{-# INLINE newListArray #-} +newListArray :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) +newListArray (l,u) es = do + marr <- newArray_ (l,u) + let n = rangeSize (l,u) + let fillFromList i xs | i == n = return () + | otherwise = case xs of + [] -> return () + y:ys -> unsafeWrite marr i y >> fillFromList (i+1) ys + fillFromList 0 es + return marr + +{-# INLINE readArray #-} +readArray :: (MArray a e m, Ix i) => a i e -> i -> m e +readArray marr i | (l,u) <- bounds marr = + unsafeRead marr (index (l,u) i) + +{-# INLINE writeArray #-} +writeArray :: (MArray a e m, Ix i) => a i e -> i -> e -> m () +writeArray marr i e | (l,u) <- bounds marr = + unsafeWrite marr (index (l,u) i) e + +{-# INLINE getElems #-} +getElems :: (MArray a e m, Ix i) => a i e -> m [e] +getElems marr | (l,u) <- bounds marr = + sequence [unsafeRead marr i | i <- [0 .. rangeSize (l,u) - 1]] + +{-# INLINE getAssocs #-} +getAssocs :: (MArray a e m, Ix i) => a i e -> m [(i, e)] +getAssocs marr | (l,u) <- bounds marr = + sequence [do e <- unsafeRead marr (index (l,u) i); return (i,e) + | i <- range (l,u)] + +{-# INLINE mapArray #-} +mapArray :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) +mapArray f marr | (l,u) <- bounds marr = do + marr' <- newArray_ (l,u) + sequence_ [do + e <- unsafeRead marr i + unsafeWrite marr' i (f e) + | i <- [0 .. rangeSize (l,u) - 1]] + return marr' + +{-# INLINE mapIndices #-} +mapIndices :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) +mapIndices (l,u) f marr = do + marr' <- newArray_ (l,u) + sequence_ [do + e <- readArray marr (f i) + unsafeWrite marr' (unsafeIndex (l,u) i) e + | i <- range (l,u)] + return marr' + +----------------------------------------------------------------------------- +-- Polymorphic non-strict mutable arrays (ST monad) + +instance HasBounds (STArray s) where + {-# INLINE bounds #-} + bounds = GHC.Arr.boundsSTArray + +instance MArray (STArray s) e (ST s) where + {-# INLINE newArray #-} + newArray = GHC.Arr.newSTArray + {-# INLINE unsafeRead #-} + unsafeRead = GHC.Arr.unsafeReadSTArray + {-# INLINE unsafeWrite #-} + unsafeWrite = GHC.Arr.unsafeWriteSTArray + +----------------------------------------------------------------------------- +-- Typeable instance for STArray + +sTArrayTc :: TyCon +sTArrayTc = mkTyCon "STArray" + +instance (Typeable a, Typeable b, Typeable c) => Typeable (STArray a b c) where + typeOf a = mkAppTy sTArrayTc [typeOf ((undefined :: STArray a b c -> a) a), + typeOf ((undefined :: STArray a b c -> b) a), + typeOf ((undefined :: STArray a b c -> c) a)] + +----------------------------------------------------------------------------- +-- Flat unboxed mutable arrays (ST monad) + +data STUArray s i a = STUArray !i !i (MutableByteArray# s) + +INSTANCE_TYPEABLE3(STUArray,stUArrayTc,"STUArray") + +instance HasBounds (STUArray s) where + {-# INLINE bounds #-} + bounds (STUArray l u _) = (l,u) + +instance MArray (STUArray s) Bool (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (bOOL_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWordArray# marr# (bOOL_INDEX i#) s1# of { (# s2#, e# #) -> + (# s2#, (e# `and#` bOOL_BIT i#) `neWord#` int2Word# 0# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) e = ST $ \s1# -> + case bOOL_INDEX i# of { j# -> + case readWordArray# marr# j# s1# of { (# s2#, old# #) -> + case if e then old# `or#` bOOL_BIT i# + else old# `and#` bOOL_NOT_BIT i# of { e# -> + case writeWordArray# marr# j# e# s2# of { s3# -> + (# s3#, () #) }}}} + +instance MArray (STUArray s) Char (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWideCharArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, C# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (C# e#) = ST $ \s1# -> + case writeWideCharArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Int (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readIntArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, I# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (I# e#) = ST $ \s1# -> + case writeIntArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Word (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWordArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, W# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (W# e#) = ST $ \s1# -> + case writeWordArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) (Ptr a) (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readAddrArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, Ptr e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (Ptr e#) = ST $ \s1# -> + case writeAddrArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) (FunPtr a) (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readAddrArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, FunPtr e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (FunPtr e#) = ST $ \s1# -> + case writeAddrArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Float (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (fLOAT_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readFloatArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, F# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (F# e#) = ST $ \s1# -> + case writeFloatArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Double (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (dOUBLE_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readDoubleArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, D# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (D# e#) = ST $ \s1# -> + case writeDoubleArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) (StablePtr a) (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (wORD_SCALE n#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readStablePtrArray# marr# i# s1# of { (# s2#, e# #) -> + (# s2# , StablePtr e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (StablePtr e#) = ST $ \s1# -> + case writeStablePtrArray# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Int8 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# n# s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readInt8Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, I8# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (I8# e#) = ST $ \s1# -> + case writeInt8Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Int16 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readInt16Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, I16# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (I16# e#) = ST $ \s1# -> + case writeInt16Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Int32 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readInt32Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, I32# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (I32# e#) = ST $ \s1# -> + case writeInt32Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Int64 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readInt64Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, I64# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (I64# e#) = ST $ \s1# -> + case writeInt64Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Word8 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# n# s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWord8Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, W8# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (W8# e#) = ST $ \s1# -> + case writeWord8Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Word16 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 2#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWord16Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, W16# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (W16# e#) = ST $ \s1# -> + case writeWord16Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Word32 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 4#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWord32Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, W32# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (W32# e#) = ST $ \s1# -> + case writeWord32Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +instance MArray (STUArray s) Word64 (ST s) where + {-# INLINE newArray_ #-} + newArray_ (l,u) = ST $ \s1# -> + case rangeSize (l,u) of { I# n# -> + case newByteArray# (n# *# 8#) s1# of { (# s2#, marr# #) -> + (# s2#, STUArray l u marr# #) }} + {-# INLINE unsafeRead #-} + unsafeRead (STUArray _ _ marr#) (I# i#) = ST $ \s1# -> + case readWord64Array# marr# i# s1# of { (# s2#, e# #) -> + (# s2#, W64# e# #) } + {-# INLINE unsafeWrite #-} + unsafeWrite (STUArray _ _ marr#) (I# i#) (W64# e#) = ST $ \s1# -> + case writeWord64Array# marr# i# e# s1# of { s2# -> + (# s2#, () #) } + +----------------------------------------------------------------------------- +-- Translation between elements and bytes + +#include "config.h" + +bOOL_SCALE, wORD_SCALE, dOUBLE_SCALE, fLOAT_SCALE :: Int# -> Int# +bOOL_SCALE n# = bOOL_INDEX (n# +# last#) where I# last# = SIZEOF_VOID_P - 1 +wORD_SCALE n# = scale# *# n# where I# scale# = SIZEOF_VOID_P +dOUBLE_SCALE n# = scale# *# n# where I# scale# = SIZEOF_DOUBLE +fLOAT_SCALE n# = scale# *# n# where I# scale# = SIZEOF_FLOAT + +bOOL_INDEX :: Int# -> Int# +#if SIZEOF_VOID_P == 4 +bOOL_INDEX i# = i# `iShiftRA#` 5# +#else +bOOL_INDEX i# = i# `iShiftRA#` 6# +#endif + +bOOL_BIT, bOOL_NOT_BIT :: Int# -> Word# +bOOL_BIT n# = int2Word# 1# `shiftL#` (word2Int# (int2Word# n# `and#` mask#)) + where W# mask# = SIZEOF_VOID_P * 8 - 1 +bOOL_NOT_BIT n# = bOOL_BIT n# `xor#` mb# where W# mb# = maxBound + +----------------------------------------------------------------------------- +-- Freezing + +freeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) +freeze marr | (l,u) <- bounds marr = do + ies <- sequence [do e <- unsafeRead marr i; return (i,e) + | i <- [0 .. rangeSize (l,u) - 1]] + return (unsafeArray (l,u) ies) + +freezeSTUArray :: Ix i => STUArray s i e -> ST s (UArray i e) +freezeSTUArray (STUArray l u marr#) = ST $ \s1# -> + case sizeofMutableByteArray# marr# of { n# -> + case newByteArray# n# s1# of { (# s2#, marr'# #) -> + case unsafeCoerce# memcpy marr'# marr# n# s2# of { (# s3#, () #) -> + case unsafeFreezeByteArray# marr'# s3# of { (# s4#, arr# #) -> + (# s4#, UArray l u arr# #) }}}} + +{-# RULES +"freeze/STArray" freeze = GHC.Arr.freezeSTArray +"freeze/STUArray" freeze = freezeSTUArray + #-} + +-- In-place conversion of mutable arrays to immutable ones places +-- a proof obligation on the user: no other parts of your code can +-- have a reference to the array at the point where you unsafely +-- freeze it (and, subsequently mutate it, I suspect). + +{-# INLINE unsafeFreeze #-} +unsafeFreeze :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) +unsafeFreeze = freeze + +{-# RULES +"unsafeFreeze/STArray" unsafeFreeze = GHC.Arr.unsafeFreezeSTArray +"unsafeFreeze/STUArray" unsafeFreeze = unsafeFreezeSTUArray + #-} + +----------------------------------------------------------------------------- +-- Thawing + +thaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) +thaw arr | (l,u) <- bounds arr = do + marr <- newArray_ (l,u) + sequence_ [unsafeWrite marr i (unsafeAt arr i) + | i <- [0 .. rangeSize (l,u) - 1]] + return marr + +thawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) +thawSTUArray (UArray l u arr#) = ST $ \s1# -> + case sizeofByteArray# arr# of { n# -> + case newByteArray# n# s1# of { (# s2#, marr# #) -> + case unsafeCoerce# memcpy marr# arr# n# s2# of { (# s3#, () #) -> + (# s3#, STUArray l u marr# #) }}} + +foreign import "memcpy" unsafe + memcpy :: MutableByteArray# RealWorld -> ByteArray# -> Int# -> IO () + +{-# RULES +"thaw/STArray" thaw = GHC.Arr.thawSTArray +"thaw/STUArray" thaw = thawSTUArray + #-} + +-- In-place conversion of immutable arrays to mutable ones places +-- a proof obligation on the user: no other parts of your code can +-- have a reference to the array at the point where you unsafely +-- thaw it (and, subsequently mutate it, I suspect). + +{-# INLINE unsafeThaw #-} +unsafeThaw :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) +unsafeThaw = thaw + +{-# INLINE unsafeThawSTUArray #-} +unsafeThawSTUArray :: Ix i => UArray i e -> ST s (STUArray s i e) +unsafeThawSTUArray (UArray l u marr#) = + return (STUArray l u (unsafeCoerce# marr#)) + +{-# RULES +"unsafeThaw/STArray" unsafeThaw = GHC.Arr.unsafeThawSTArray +"unsafeThaw/STUArray" unsafeThaw = unsafeThawSTUArray + #-} diff --git a/libraries/base/Data/Array/IArray.hs b/libraries/base/Data/Array/IArray.hs new file mode 100644 index 0000000000..b97daeec6a --- /dev/null +++ b/libraries/base/Data/Array/IArray.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.IArray +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: IArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Overloaded immutable array class. +-- +----------------------------------------------------------------------------- + +module Data.Array.IArray ( + module Data.Ix, + + -- Class of immutable array types + IArray, -- :: (* -> * -> *) -> * -> class + -- Class of array types with immutable bounds + HasBounds, -- :: (* -> * -> *) -> class + + array, -- :: (IArray a e, Ix i) => (i,i) -> [(i, e)] -> a i e + listArray, -- :: (IArray a e, Ix i) => (i,i) -> [e] -> a i e + (!), -- :: (IArray a e, Ix i) => a i e -> i -> e + bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i) + indices, -- :: (HasBounds a, Ix i) => a i e -> [i] + elems, -- :: (IArray a e, Ix i) => a i e -> [e] + assocs, -- :: (IArray a e, Ix i) => a i e -> [(i, e)] + accumArray, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> e -> (i,i) -> [(i, e')] -> a i e + (//), -- :: (IArray a e, Ix i) => a i e -> [(i, e)] -> a i e + accum, -- :: (IArray a e, Ix i) => (e -> e' -> e) -> a i e -> [(i, e')] -> a i e + amap, -- :: (IArray a e', IArray a e, Ix i) => (e' -> e) -> a i e' -> a i e + ixmap) -- :: (IArray a e, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> a i e + where + +import Prelude + +import Data.Ix +import Data.Array.Base diff --git a/libraries/base/Data/Array/IO.hs b/libraries/base/Data/Array/IO.hs new file mode 100644 index 0000000000..9e7892ef50 --- /dev/null +++ b/libraries/base/Data/Array/IO.hs @@ -0,0 +1,365 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.IO +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: IO.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Mutable boxed/unboxed arrays in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.Array.IO ( + module Data.Array.MArray, + IOArray, -- instance of: Eq, Typeable + IOUArray, -- instance of: Eq, Typeable + castIOUArray, -- :: IOUArray i a -> IO (IOUArray i b) + ) where + +import Prelude + +import Data.Array ( Array ) +import Data.Array.MArray +import Data.Int +import Data.Word +import Data.Dynamic + +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) + +#ifdef __GLASGOW_HASKELL__ +-- GHC only to the end of file + +import Data.Array.Base +import GHC.Arr ( STArray, freezeSTArray, unsafeFreezeSTArray, + thawSTArray, unsafeThawSTArray ) + +import GHC.ST ( ST(..) ) +import GHC.IOBase ( stToIO ) + +import GHC.Base + +----------------------------------------------------------------------------- +-- Polymorphic non-strict mutable arrays (IO monad) + +newtype IOArray i e = IOArray (STArray RealWorld i e) deriving Eq + +iOArrayTc :: TyCon +iOArrayTc = mkTyCon "IOArray" + +instance (Typeable a, Typeable b) => Typeable (IOArray a b) where + typeOf a = mkAppTy iOArrayTc [typeOf ((undefined :: IOArray a b -> a) a), + typeOf ((undefined :: IOArray a b -> b) a)] + +instance HasBounds IOArray where + {-# INLINE bounds #-} + bounds (IOArray marr) = bounds marr + +instance MArray IOArray e IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e) + +----------------------------------------------------------------------------- +-- Flat unboxed mutable arrays (IO monad) + +newtype IOUArray i e = IOUArray (STUArray RealWorld i e) deriving Eq + +iOUArrayTc :: TyCon +iOUArrayTc = mkTyCon "IOUArray" + +instance (Typeable a, Typeable b) => Typeable (IOUArray a b) where + typeOf a = mkAppTy iOUArrayTc [typeOf ((undefined :: IOUArray a b -> a) a), + typeOf ((undefined :: IOUArray a b -> b) a)] + +instance HasBounds IOUArray where + {-# INLINE bounds #-} + bounds (IOUArray marr) = bounds marr + +instance MArray IOUArray Bool IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Char IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (Ptr a) IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (FunPtr a) IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Float IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Double IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (StablePtr a) IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int8 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int16 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int32 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int64 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word8 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word16 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word32 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word64 IO where + {-# INLINE newArray #-} + newArray lu init = stToIO $ do + marr <- newArray lu init; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ lu = stToIO $ do + marr <- newArray_ lu; return (IOUArray marr) + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +----------------------------------------------------------------------------- +-- Freezing + +freezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e) +freezeIOArray (IOArray marr) = stToIO (freezeSTArray marr) + +freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) + +{-# RULES +"freeze/IOArray" freeze = freezeIOArray +"freeze/IOUArray" freeze = freezeIOUArray + #-} + +{-# INLINE unsafeFreezeIOArray #-} +unsafeFreezeIOArray :: Ix ix => IOArray ix e -> IO (Array ix e) +unsafeFreezeIOArray (IOArray marr) = stToIO (unsafeFreezeSTArray marr) + +{-# INLINE unsafeFreezeIOUArray #-} +unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) + +{-# RULES +"unsafeFreeze/IOArray" unsafeFreeze = unsafeFreezeIOArray +"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray + #-} + +----------------------------------------------------------------------------- +-- Thawing + +thawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e) +thawIOArray arr = stToIO $ do + marr <- thawSTArray arr + return (IOArray marr) + +thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +thawIOUArray arr = stToIO $ do + marr <- thawSTUArray arr + return (IOUArray marr) + +{-# RULES +"thaw/IOArray" thaw = thawIOArray +"thaw/IOUArray" thaw = thawIOUArray + #-} + +{-# INLINE unsafeThawIOArray #-} +unsafeThawIOArray :: Ix ix => Array ix e -> IO (IOArray ix e) +unsafeThawIOArray arr = stToIO $ do + marr <- unsafeThawSTArray arr + return (IOArray marr) + +{-# INLINE unsafeThawIOUArray #-} +unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +unsafeThawIOUArray arr = stToIO $ do + marr <- unsafeThawSTUArray arr + return (IOUArray marr) + +{-# RULES +"unsafeThaw/IOArray" unsafeThaw = unsafeThawIOArray +"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray + #-} + +castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b) +castSTUArray (STUArray l u marr#) = return (STUArray l u marr#) + +castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) +castIOUArray (IOUArray marr) = stToIO $ do + marr' <- castSTUArray marr + return (IOUArray marr') + +#endif /* __GLASGOW_HASKELL__ */ diff --git a/libraries/base/Data/Array/MArray.hs b/libraries/base/Data/Array/MArray.hs new file mode 100644 index 0000000000..c341dab6da --- /dev/null +++ b/libraries/base/Data/Array/MArray.hs @@ -0,0 +1,47 @@ +{-# OPTIONS -monly-3-regs #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.MArray +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: MArray.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Class of mutable arrays, and operations on them. +-- +----------------------------------------------------------------------------- + +module Data.Array.MArray ( + module Data.Ix, + + -- Class of mutable array types + MArray, -- :: (* -> * -> *) -> * -> (* -> *) -> class + -- Class of array types with immutable bounds + HasBounds, -- :: (* -> * -> *) -> class + + newArray, -- :: (MArray a e m, Ix i) => (i,i) -> e -> m (a i e) + newArray_, -- :: (MArray a e m, Ix i) => (i,i) -> m (a i e) + newListArray, -- :: (MArray a e m, Ix i) => (i,i) -> [e] -> m (a i e) + readArray, -- :: (MArray a e m, Ix i) => a i e -> i -> m e + writeArray, -- :: (MArray a e m, Ix i) => a i e -> i -> e -> m () + bounds, -- :: (HasBounds a, Ix i) => a i e -> (i,i) + indices, -- :: (HasBounds a, Ix i) => a i e -> [i] + getElems, -- :: (MArray a e m, Ix i) => a i e -> m [e] + getAssocs, -- :: (MArray a e m, Ix i) => a i e -> m [(i, e)] + mapArray, -- :: (MArray a e' m, MArray a e m, Ix i) => (e' -> e) -> a i e' -> m (a i e) + mapIndices, -- :: (MArray a e m, Ix i, Ix j) => (i,i) -> (i -> j) -> a j e -> m (a i e) + + freeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) + unsafeFreeze, -- :: (Ix i, MArray a e m, IArray b e) => a i e -> m (b i e) + thaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) + unsafeThaw, -- :: (Ix i, IArray a e, MArray b e m) => a i e -> m (b i e) + ) where + +import Prelude + +import Data.Ix +import Data.Array.Base diff --git a/libraries/base/Data/Array/ST.hs b/libraries/base/Data/Array/ST.hs new file mode 100644 index 0000000000..143f792df0 --- /dev/null +++ b/libraries/base/Data/Array/ST.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.ST +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: ST.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Mutable boxed/unboxed arrays in the ST monad. +-- +----------------------------------------------------------------------------- + +module Data.Array.ST ( + module Data.Array.MArray, + STArray, -- instance of: Eq, MArray + STUArray, -- instance of: Eq, MArray + castSTUArray, -- :: STUArray s i a -> ST s (STUArray s i b) + ) where + +import Prelude + +import Data.Array.MArray +import Data.Array.Base + +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr +import GHC.ST + +castSTUArray :: STUArray s ix a -> ST s (STUArray s ix b) +castSTUArray (STUArray l u marr#) = return (STUArray l u marr#) +#endif diff --git a/libraries/base/Data/Array/Unboxed.hs b/libraries/base/Data/Array/Unboxed.hs new file mode 100644 index 0000000000..b4a0ecfc02 --- /dev/null +++ b/libraries/base/Data/Array/Unboxed.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Array.Unboxed +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Unboxed.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Unboxed immutable array type. +-- +----------------------------------------------------------------------------- + +module Data.Array.Unboxed ( + module Data.Array.IArray, + UArray, + ) where + +import Prelude + +import Data.Array.IArray +import Data.Array.Base diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs new file mode 100644 index 0000000000..8a37e82bd9 --- /dev/null +++ b/libraries/base/Data/Bits.hs @@ -0,0 +1,143 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Bits +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Bits.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Bitwise operations. +-- +----------------------------------------------------------------------------- + +module Data.Bits ( + Bits( + (.&.), (.|.), xor, -- :: a -> a -> a + complement, -- :: a -> a + shift, -- :: a -> Int -> a + rotate, -- :: a -> Int -> a + bit, -- :: Int -> a + setBit, -- :: a -> Int -> a + clearBit, -- :: a -> Int -> a + complementBit, -- :: a -> Int -> a + testBit, -- :: a -> Int -> Bool + bitSize, -- :: a -> Int + isSigned -- :: a -> Bool + ), + shiftL, shiftR, -- :: Bits a => a -> Int -> a + rotateL, rotateR, -- :: Bits a => a -> Int -> a + -- instance Bits Int + -- instance Bits Integer + ) where + +-- Defines the @Bits@ class containing bit-based operations. +-- See library document for details on the semantics of the +-- individual operations. + +#ifdef __GLASGOW_HASKELL__ +#include "MachDeps.h" +import GHC.Num +import GHC.Real +import GHC.Base +#endif + +--ADR: The fixity for .|. conflicts with that for .|. in Fran. +-- Removing all fixities is a fairly safe fix; fixing the "one fixity +-- per symbol per program" limitation in Hugs would take a lot longer. +#ifndef __HUGS__ +infixl 8 `shift`, `rotate` +infixl 7 .&. +infixl 6 `xor` +infixl 5 .|. +#endif + +class Num a => Bits a where + (.&.), (.|.), xor :: a -> a -> a + complement :: a -> a + shift :: a -> Int -> a + rotate :: a -> Int -> a + bit :: Int -> a + setBit :: a -> Int -> a + clearBit :: a -> Int -> a + complementBit :: a -> Int -> a + testBit :: a -> Int -> Bool + bitSize :: a -> Int + isSigned :: a -> Bool + + bit i = 1 `shift` i + x `setBit` i = x .|. bit i + x `clearBit` i = x .&. complement (bit i) + x `complementBit` i = x `xor` bit i + x `testBit` i = (x .&. bit i) /= 0 + +shiftL, shiftR :: Bits a => a -> Int -> a +rotateL, rotateR :: Bits a => a -> Int -> a +x `shiftL` i = x `shift` i +x `shiftR` i = x `shift` (-i) +x `rotateL` i = x `rotate` i +x `rotateR` i = x `rotate` (-i) + +#ifdef __GLASGOW_HASKELL__ +instance Bits Int where + (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#)) + (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#)) + (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#)) + complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) + (I# x#) `shift` (I# i#) + | i# >=# 0# = I# (x# `iShiftL#` i#) + | otherwise = I# (x# `iShiftRA#` negateInt# i#) + (I# x#) `rotate` (I# i#) = +#if WORD_SIZE_IN_BYTES == 4 + I# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (32# -# i'#)))) + where + x'# = int2Word# x# + i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) +#else + I# (word2Int# ((x'# `shiftL#` i'#) `or#` + (x'# `shiftRL#` (64# -# i'#)))) + where + x'# = int2Word# x# + i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) +#endif + bitSize _ = WORD_SIZE_IN_BYTES * 8 + isSigned _ = True + +instance Bits Integer where + (S# x) .&. (S# y) = S# (word2Int# (int2Word# x `and#` int2Word# y)) + x@(S# _) .&. y = toBig x .&. y + x .&. y@(S# _) = x .&. toBig y + (J# s1 d1) .&. (J# s2 d2) = + case andInteger# s1 d1 s2 d2 of + (# s, d #) -> J# s d + + (S# x) .|. (S# y) = S# (word2Int# (int2Word# x `or#` int2Word# y)) + x@(S# _) .|. y = toBig x .|. y + x .|. y@(S# _) = x .|. toBig y + (J# s1 d1) .|. (J# s2 d2) = + case orInteger# s1 d1 s2 d2 of + (# s, d #) -> J# s d + + (S# x) `xor` (S# y) = S# (word2Int# (int2Word# x `xor#` int2Word# y)) + x@(S# _) `xor` y = toBig x `xor` y + x `xor` y@(S# _) = x `xor` toBig y + (J# s1 d1) `xor` (J# s2 d2) = + case xorInteger# s1 d1 s2 d2 of + (# s, d #) -> J# s d + + complement (S# x) = S# (word2Int# (int2Word# x `xor#` int2Word# (0# -# 1#))) + complement (J# s d) = case complementInteger# s d of (# s, d #) -> J# s d + + shift x i | i >= 0 = x * 2^i + | otherwise = x `div` 2^(-i) + + rotate x i = shift x i -- since an Integer never wraps around + + bitSize _ = error "Bits.bitSize(Integer)" + isSigned _ = True +#endif diff --git a/libraries/base/Data/Bool.hs b/libraries/base/Data/Bool.hs new file mode 100644 index 0000000000..33804d2705 --- /dev/null +++ b/libraries/base/Data/Bool.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Bool +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Bool.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Bool type and related functions. +-- +----------------------------------------------------------------------------- + +module Data.Bool ( + Bool(..), + (&&), -- :: Bool -> Bool -> Bool + (||), -- :: Bool -> Bool -> Bool + not, -- :: Bool -> Bool + otherwise, -- :: Bool + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +#endif diff --git a/libraries/base/Data/Char.hs b/libraries/base/Data/Char.hs new file mode 100644 index 0000000000..e0c9566f5f --- /dev/null +++ b/libraries/base/Data/Char.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Char +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Char.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Char type and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.Char + ( + Char + + , isAscii, isLatin1, isControl + , isPrint, isSpace, isUpper + , isLower, isAlpha, isDigit + , isOctDigit, isHexDigit, isAlphaNum -- :: Char -> Bool + + , toUpper, toLower -- :: Char -> Char + + , digitToInt -- :: Char -> Int + , intToDigit -- :: Int -> Char + + , ord -- :: Char -> Int + , chr -- :: Int -> Char + , readLitChar -- :: ReadS Char + , showLitChar -- :: Char -> ShowS + , lexLitChar -- :: ReadS String + + , String + + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Show +import GHC.Read (readLitChar, lexLitChar, digitToInt) +#endif + +#ifdef __HUGS__ +isLatin1 c = True +#endif diff --git a/libraries/base/Data/Complex.hs b/libraries/base/Data/Complex.hs new file mode 100644 index 0000000000..e132f2186c --- /dev/null +++ b/libraries/base/Data/Complex.hs @@ -0,0 +1,153 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Complex +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Complex.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Complex numbers. +-- +----------------------------------------------------------------------------- + +module Data.Complex + ( Complex((:+)) + + , realPart -- :: (RealFloat a) => Complex a -> a + , imagPart -- :: (RealFloat a) => Complex a -> a + , conjugate -- :: (RealFloat a) => Complex a -> Complex a + , mkPolar -- :: (RealFloat a) => a -> a -> Complex a + , cis -- :: (RealFloat a) => a -> Complex a + , polar -- :: (RealFloat a) => Complex a -> (a,a) + , magnitude -- :: (RealFloat a) => Complex a -> a + , phase -- :: (RealFloat a) => Complex a -> a + + -- Complex instances: + -- + -- (RealFloat a) => Eq (Complex a) + -- (RealFloat a) => Read (Complex a) + -- (RealFloat a) => Show (Complex a) + -- (RealFloat a) => Num (Complex a) + -- (RealFloat a) => Fractional (Complex a) + -- (RealFloat a) => Floating (Complex a) + -- + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + + ) where + +import Prelude + +import Data.Dynamic + +infix 6 :+ + +-- ----------------------------------------------------------------------------- +-- The Complex type + +data (RealFloat a) => Complex a = !a :+ !a deriving (Eq, Read, Show) + + +-- ----------------------------------------------------------------------------- +-- Functions over Complex + +realPart, imagPart :: (RealFloat a) => Complex a -> a +realPart (x :+ _) = x +imagPart (_ :+ y) = y + +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +magnitude :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int))) + where k = max (exponent x) (exponent y) + mk = - k + +phase :: (RealFloat a) => Complex a -> a +phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson +phase (x:+y) = atan2 y x + + +-- ----------------------------------------------------------------------------- +-- Instances of Complex + +#include "Dynamic.h" +INSTANCE_TYPEABLE1(Complex,complexTc,"Complex") + +instance (RealFloat a) => Num (Complex a) where + {-# SPECIALISE instance Num (Complex Float) #-} + {-# SPECIALISE instance Num (Complex Double) #-} + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + +instance (RealFloat a) => Fractional (Complex a) where + {-# SPECIALISE instance Fractional (Complex Float) #-} + {-# SPECIALISE instance Fractional (Complex Double) #-} + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 + +instance (RealFloat a) => Floating (Complex a) where + {-# SPECIALISE instance Floating (Complex Float) #-} + {-# SPECIALISE instance Floating (Complex Double) #-} + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + sqrt 0 = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs new file mode 100644 index 0000000000..42313fd07c --- /dev/null +++ b/libraries/base/Data/Dynamic.hs @@ -0,0 +1,288 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Dynamic +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Dynamic.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Dynamic interface provides basic support for dynamic types. +-- +-- Operations for injecting values of arbitrary type into +-- a dynamically typed value, Dynamic, are provided, together +-- with operations for converting dynamic values into a concrete +-- (monomorphic) type. +-- +-- The Dynamic implementation provided is closely based on code +-- contained in Hugs library of the same name. +-- +----------------------------------------------------------------------------- + +module Data.Dynamic + ( + -- dynamic type + Dynamic -- abstract, instance of: Show, Typeable + , toDyn -- :: Typeable a => a -> Dynamic + , fromDyn -- :: Typeable a => Dynamic -> a -> a + , fromDynamic -- :: Typeable a => Dynamic -> Maybe a + + -- type representation + + , Typeable( + typeOf) -- :: a -> TypeRep + + -- Dynamic defines Typeable instances for the following + -- Prelude types: [a], (), (a,b), (a,b,c), (a,b,c,d), + -- (a,b,c,d,e), (a->b), (Array a b), Bool, Char, + -- (Complex a), Double, (Either a b), Float, Handle, + -- Int, Integer, (IO a), (Maybe a), Ordering + + , TypeRep -- abstract, instance of: Eq, Show, Typeable + , TyCon -- abstract, instance of: Eq, Show, Typeable + + -- type representation constructors/operators: + , mkTyCon -- :: String -> TyCon + , mkAppTy -- :: TyCon -> [TypeRep] -> TypeRep + , mkFunTy -- :: TypeRep -> TypeRep -> TypeRep + , applyTy -- :: TypeRep -> TypeRep -> Maybe TypeRep + + -- + -- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,") + -- [fTy,fTy,fTy]) + -- + -- returns "(Foo,Foo,Foo)" + -- + -- The TypeRep Show instance promises to print tuple types + -- correctly. Tuple type constructors are specified by a + -- sequence of commas, e.g., (mkTyCon ",,,,") returns + -- the 5-tuple tycon. + ) where + + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Maybe +import GHC.Show +import GHC.Err +import GHC.Num +import GHC.Float +import GHC.IOBase +import GHC.Dynamic +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Prim ( unsafeCoerce# ) + +unsafeCoerce :: a -> b +unsafeCoerce = unsafeCoerce# +#endif + +#include "Dynamic.h" + +-- The dynamic type is represented by Dynamic, carrying +-- the dynamic value along with its type representation: + +-- the instance just prints the type representation. +instance Show Dynamic where + showsPrec _ (Dynamic t _) = + showString "<<" . + showsPrec 0 t . + showString ">>" + +-- Operations for going to and from Dynamic: + +toDyn :: Typeable a => a -> Dynamic +toDyn v = Dynamic (typeOf v) (unsafeCoerce v) + +fromDyn :: Typeable a => Dynamic -> a -> a +fromDyn (Dynamic t v) def + | typeOf def == t = unsafeCoerce v + | otherwise = def + +fromDynamic :: Typeable a => Dynamic -> Maybe a +fromDynamic (Dynamic t v) = + case unsafeCoerce v of + r | t == typeOf r -> Just r + | otherwise -> Nothing + +-- (Abstract) universal datatype: + +instance Show TypeRep where + showsPrec p (App tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + xs + | isTupleTyCon tycon -> showTuple tycon xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + + showsPrec p (Fun f a) = + showParen (p > 8) $ + showsPrec 9 f . showString " -> " . showsPrec 8 a + +-- To make it possible to convert values with user-defined types +-- into type Dynamic, we need a systematic way of getting +-- the type representation of an arbitrary type. A type +-- class provides just the ticket, + +class Typeable a where + typeOf :: a -> TypeRep + +-- NOTE: The argument to the overloaded `typeOf' is only +-- used to carry type information, and Typeable instances +-- should *never* *ever* look at its value. + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ (',':_)) = True +isTupleTyCon _ = False + +instance Show TyCon where + showsPrec _ (TyCon _ s) = showString s + +-- If we enforce the restriction that there is only one +-- @TyCon@ for a type & it is shared among all its uses, +-- we can map them onto Ints very simply. The benefit is, +-- of course, that @TyCon@s can then be compared efficiently. + +-- Provided the implementor of other @Typeable@ instances +-- takes care of making all the @TyCon@s CAFs (toplevel constants), +-- this will work. + +-- If this constraint does turn out to be a sore thumb, changing +-- the Eq instance for TyCons is trivial. + +mkTyCon :: String -> TyCon +mkTyCon str = unsafePerformIO $ do + v <- readIORef uni + writeIORef uni (v+1) + return (TyCon v str) + +{-# NOINLINE uni #-} +uni :: IORef Int +uni = unsafePerformIO ( newIORef 0 ) + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: TyCon -> [TypeRep] -> ShowS +showTuple (TyCon _ str) args = showChar '(' . go str args + where + go [] [a] = showsPrec 10 a . showChar ')' + go _ [] = showChar ')' -- a failure condition, really. + go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as + go _ _ = showChar ')' + + +mkAppTy :: TyCon -> [TypeRep] -> TypeRep +mkAppTy tyc args = App tyc args + +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = Fun f a + +-- Auxillary functions + +-- (f::(a->b)) `dynApply` (x::a) = (f a)::b +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = + case applyTy t1 t2 of + Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) + Nothing -> Nothing + +dynApp :: Dynamic -> Dynamic -> Dynamic +dynApp f x = case dynApply f x of + Just r -> r + Nothing -> error ("Type error in dynamic application.\n" ++ + "Can't apply function " ++ show f ++ + " to argument " ++ show x) + +applyTy :: TypeRep -> TypeRep -> Maybe TypeRep +applyTy (Fun t1 t2) t3 + | t1 == t3 = Just t2 +applyTy _ _ = Nothing + +-- Prelude types + +listTc :: TyCon +listTc = mkTyCon "[]" + +instance Typeable a => Typeable [a] where + typeOf ls = mkAppTy listTc [typeOf ((undefined:: [a] -> a) ls)] + +unitTc :: TyCon +unitTc = mkTyCon "()" + +instance Typeable () where + typeOf _ = mkAppTy unitTc [] + +tup2Tc :: TyCon +tup2Tc = mkTyCon "," + +instance (Typeable a, Typeable b) => Typeable (a,b) where + typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu), + typeOf ((undefined :: (a,b) -> b) tu)] + +tup3Tc :: TyCon +tup3Tc = mkTyCon ",," + +instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where + typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu), + typeOf ((undefined :: (a,b,c) -> b) tu), + typeOf ((undefined :: (a,b,c) -> c) tu)] + +tup4Tc :: TyCon +tup4Tc = mkTyCon ",,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d) => Typeable (a,b,c,d) where + typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu), + typeOf ((undefined :: (a,b,c,d) -> b) tu), + typeOf ((undefined :: (a,b,c,d) -> c) tu), + typeOf ((undefined :: (a,b,c,d) -> d) tu)] + +tup5Tc :: TyCon +tup5Tc = mkTyCon ",,,," + +instance ( Typeable a + , Typeable b + , Typeable c + , Typeable d + , Typeable e) => Typeable (a,b,c,d,e) where + typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu), + typeOf ((undefined :: (a,b,c,d,e) -> b) tu), + typeOf ((undefined :: (a,b,c,d,e) -> c) tu), + typeOf ((undefined :: (a,b,c,d,e) -> d) tu), + typeOf ((undefined :: (a,b,c,d,e) -> e) tu)] + +instance (Typeable a, Typeable b) => Typeable (a -> b) where + typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f)) + (typeOf ((undefined :: (a -> b) -> b) f)) + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE2(Either,eitherTc,"Either") +INSTANCE_TYPEABLE1(IO,ioTc,"IO") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") +INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic") diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs new file mode 100644 index 0000000000..f3cd106655 --- /dev/null +++ b/libraries/base/Data/Either.hs @@ -0,0 +1,25 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Either +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Either.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Either type, and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.Either ( + Either(..), + either -- :: (a -> c) -> (b -> c) -> Either a b -> c + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Maybe +#endif diff --git a/libraries/base/Data/IORef.hs b/libraries/base/Data/IORef.hs new file mode 100644 index 0000000000..f0738277dd --- /dev/null +++ b/libraries/base/Data/IORef.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.IORef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: IORef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Mutable references in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.IORef + ( IORef -- abstract, instance of: Eq, Typeable + , newIORef -- :: a -> IO (IORef a) + , readIORef -- :: IORef a -> IO a + , writeIORef -- :: IORef a -> a -> IO () + , modifyIORef -- :: IORef a -> (a -> a) -> IO () + +#if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__) + , mkWeakIORef -- :: IORef a -> IO () -> IO (Weak (IORef a)) +#endif + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.Prim ( mkWeak# ) +import GHC.STRef +import GHC.IOBase +#if !defined(__PARALLEL_HASKELL__) +import GHC.Weak +#endif +#endif /* __GLASGOW_HASKELL__ */ + +#ifdef __HUGS__ +import IOExts ( IORef, newIORef, writeIORef, readIORef ) +import ST ( stToIO, newSTRef, readSTRef, writeSTRef ) +#endif + +import Data.Dynamic + +#ifndef __PARALLEL_HASKELL__ +mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a)) +mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s -> + case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #) +#endif + +modifyIORef :: IORef a -> (a -> a) -> IO () +modifyIORef ref f = writeIORef ref . f =<< readIORef ref + +#include "Dynamic.h" +INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef") diff --git a/libraries/base/Data/Int.hs b/libraries/base/Data/Int.hs new file mode 100644 index 0000000000..3a1042a433 --- /dev/null +++ b/libraries/base/Data/Int.hs @@ -0,0 +1,37 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Int +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Int.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Sized Integer types. +-- +----------------------------------------------------------------------------- + +module Data.Int + ( Int8 + , Int16 + , Int32 + , Int64 + -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read, + -- Show, Bits, CCallable, CReturnable (last two are GHC specific.) + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Int +#endif + +import Data.Dynamic + +#include "Dynamic.h" +INSTANCE_TYPEABLE0(Int8,int8Tc, "Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") diff --git a/libraries/base/Data/Ix.hs b/libraries/base/Data/Ix.hs new file mode 100644 index 0000000000..8d4d7452e2 --- /dev/null +++ b/libraries/base/Data/Ix.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Ix +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Ix.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Class of index types. +-- +----------------------------------------------------------------------------- + +module Data.Ix + ( + Ix + ( range -- :: (Ix a) => (a,a) -> [a] + , index -- :: (Ix a) => (a,a) -> a -> Int + , inRange -- :: (Ix a) => (a,a) -> a -> Bool + ) + , rangeSize -- :: (Ix a) => (a,a) -> Int + -- Ix instances: + -- + -- Ix Char + -- Ix Int + -- Ix Integer + -- Ix Bool + -- Ix Ordering + -- Ix () + -- (Ix a, Ix b) => Ix (a, b) + -- ... + + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.Arr +#endif diff --git a/libraries/base/Data/List.hs b/libraries/base/Data/List.hs new file mode 100644 index 0000000000..ce4c9b32f2 --- /dev/null +++ b/libraries/base/Data/List.hs @@ -0,0 +1,537 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.List +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: List.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Operations on lists. +-- +----------------------------------------------------------------------------- + +module Data.List + ( + [] (..), + + , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int + , elemIndices -- :: (Eq a) => a -> [a] -> [Int] + + , find -- :: (a -> Bool) -> [a] -> Maybe a + , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int + , findIndices -- :: (a -> Bool) -> [a] -> [Int] + + , nub -- :: (Eq a) => [a] -> [a] + , nubBy -- :: (a -> a -> Bool) -> [a] -> [a] + + , delete -- :: (Eq a) => a -> [a] -> [a] + , deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a] + , (\\) -- :: (Eq a) => [a] -> [a] -> [a] + , deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , union -- :: (Eq a) => [a] -> [a] -> [a] + , unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , intersect -- :: (Eq a) => [a] -> [a] -> [a] + , intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , intersperse -- :: a -> [a] -> [a] + , transpose -- :: [[a]] -> [[a]] + , partition -- :: (a -> Bool) -> [a] -> ([a], [a]) + + , group -- :: Eq a => [a] -> [[a]] + , groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]] + + , inits -- :: [a] -> [[a]] + , tails -- :: [a] -> [[a]] + + , isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool + , isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool + + , mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) + , mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) + + , sort -- :: (Ord a) => [a] -> [a] + , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a] + + , insert -- :: (Ord a) => a -> [a] -> [a] + , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a] + + , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a + , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a + + , genericLength -- :: (Integral a) => [b] -> a + , genericTake -- :: (Integral a) => a -> [b] -> [b] + , genericDrop -- :: (Integral a) => a -> [b] -> [b] + , genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b]) + , genericIndex -- :: (Integral a) => [b] -> a -> b + , genericReplicate -- :: (Integral a) => a -> b -> [b] + + , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a] + + , zip4, zip5, zip6, zip7 + , zipWith4, zipWith5, zipWith6, zipWith7 + , unzip4, unzip5, unzip6, unzip7 + + , map -- :: ( a -> b ) -> [a] -> [b] + , (++) -- :: [a] -> [a] -> [a] + , concat -- :: [[a]] -> [a] + , filter -- :: (a -> Bool) -> [a] -> [a] + , head -- :: [a] -> a + , last -- :: [a] -> a + , tail -- :: [a] -> [a] + , init -- :: [a] -> [a] + , null -- :: [a] -> Bool + , length -- :: [a] -> Int + , (!!) -- :: [a] -> Int -> a + , foldl -- :: (a -> b -> a) -> a -> [b] -> a + , foldl1 -- :: (a -> a -> a) -> [a] -> a + , scanl -- :: (a -> b -> a) -> a -> [b] -> [a] + , scanl1 -- :: (a -> a -> a) -> [a] -> [a] + , foldr -- :: (a -> b -> b) -> b -> [a] -> b + , foldr1 -- :: (a -> a -> a) -> [a] -> a + , scanr -- :: (a -> b -> b) -> b -> [a] -> [b] + , scanr1 -- :: (a -> a -> a) -> [a] -> [a] + , iterate -- :: (a -> a) -> a -> [a] + , repeat -- :: a -> [a] + , replicate -- :: Int -> a -> [a] + , cycle -- :: [a] -> [a] + , take -- :: Int -> [a] -> [a] + , drop -- :: Int -> [a] -> [a] + , splitAt -- :: Int -> [a] -> ([a], [a]) + , takeWhile -- :: (a -> Bool) -> [a] -> [a] + , dropWhile -- :: (a -> Bool) -> [a] -> [a] + , span -- :: (a -> Bool) -> [a] -> ([a], [a]) + , break -- :: (a -> Bool) -> [a] -> ([a], [a]) + + , lines -- :: String -> [String] + , words -- :: String -> [String] + , unlines -- :: [String] -> String + , unwords -- :: [String] -> String + , reverse -- :: [a] -> [a] + , and -- :: [Bool] -> Bool + , or -- :: [Bool] -> Bool + , any -- :: (a -> Bool) -> [a] -> Bool + , all -- :: (a -> Bool) -> [a] -> Bool + , elem -- :: a -> [a] -> Bool + , notElem -- :: a -> [a] -> Bool + , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b + , sum -- :: (Num a) => [a] -> a + , product -- :: (Num a) => [a] -> a + , maximum -- :: (Ord a) => [a] -> a + , minimum -- :: (Ord a) => [a] -> a + , concatMap -- :: (a -> [b]) -> [a] -> [b] + , zip -- :: [a] -> [b] -> [(a,b)] + , zip3 + , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c] + , zipWith3 + , unzip -- :: [(a,b)] -> ([a],[b]) + , unzip3 + + ) where + +import Data.Maybe + +#ifdef __GLASGOW_HASKELL__ +import GHC.Num +import GHC.Real +import GHC.List +import GHC.Show ( lines, words, unlines, unwords ) +import GHC.Base +#endif + +infix 5 \\ + +-- ----------------------------------------------------------------------------- +-- List functions + +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) + +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) + +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +findIndices :: (a -> Bool) -> [a] -> [Int] + +#ifdef USE_REPORT_PRELUDE +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] +#else +#ifdef __HUGS__ +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] +#else +-- Efficient definition +findIndices p ls = loop 0# ls + where + loop _ [] = [] + loop n (x:xs) | p x = I# n : loop (n +# 1#) xs + | otherwise = loop (n +# 1#) xs +#endif /* __HUGS__ */ +#endif /* USE_REPORT_PRELUDE */ + +isPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys + +isSuffixOf :: (Eq a) => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +-- nub (meaning "essence") remove duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +#ifdef USE_REPORT_PRELUDE +nub = nubBy (==) +#else +-- stolen from HBC +nub l = nub' l [] -- ' + where + nub' [] _ = [] -- ' + nub' (x:xs) ls -- ' + | x `elem` ls = nub' xs ls -- ' + | otherwise = x : nub' xs (x:ls) -- ' +#endif + +nubBy :: (a -> a -> Bool) -> [a] -> [a] +#ifdef USE_REPORT_PRELUDE +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) +#else +nubBy eq l = nubBy' l [] + where + nubBy' [] _ = [] + nubBy' (y:ys) xs + | elem_by eq y xs = nubBy' ys xs + | otherwise = y : nubBy' ys (y:xs) + +-- Not exported: +-- Note that we keep the call to `eq` with arguments in the +-- same order as in the reference implementation +-- 'xs' is the list of things we've seen so far, +-- 'y' is the potential new element +elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool +elem_by _ _ [] = False +elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs +#endif + + +-- delete x removes the first occurrence of x from its list argument. +delete :: (Eq a) => a -> [a] -> [a] +delete = deleteBy (==) + +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy _ _ [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +-- list difference (non-associative). In the result of xs \\ ys, +-- the first occurrence of each element of ys in turn (if any) +-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +-- List union, remove the elements of first list from second. +union :: (Eq a) => [a] -> [a] -> [a] +union = unionBy (==) + +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +intersect :: (Eq a) => [a] -> [a] -> [a] +intersect = intersectBy (==) + +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +-- intersperse sep inserts sep between the elements of its list argument. +-- e.g. intersperse ',' "abcde" == "a,b,c,d,e" +intersperse :: a -> [a] -> [a] +intersperse _ [] = [] +intersperse _ [x] = [x] +intersperse sep (x:xs) = x : sep : intersperse sep xs + +transpose :: [[a]] -> [[a]] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) + + +-- partition takes a predicate and a list and returns a pair of lists: +-- those elements of the argument list that do and do not satisfy the +-- predicate, respectively; i,e,, +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +{-# INLINE partition #-} +partition p xs = foldr (select p) ([],[]) xs + +select p x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + +-- @mapAccumL@ behaves like a combination +-- of @map@ and @foldl@; +-- it applies a function to each element of a list, passing an accumulating +-- parameter from left to right, and returning a final value of this +-- accumulator together with the new list. + +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumL _ s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +-- @mapAccumR@ does the same, but working from right to left instead. +-- Its type is the same as @mapAccumL@, though. + +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumR _ s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs + + +insert :: Ord a => a -> [a] -> [a] +insert e ls = insertBy (compare) e ls + +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy _ x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys + +maximumBy :: (a -> a -> a) -> [a] -> a +maximumBy _ [] = error "List.maximumBy: empty list" +maximumBy max xs = foldl1 max xs + +minimumBy :: (a -> a -> a) -> [a] -> a +minimumBy _ [] = error "List.minimumBy: empty list" +minimumBy min xs = foldl1 min xs + +genericLength :: (Num i) => [b] -> i +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l + +genericTake :: (Integral i) => i -> [a] -> [a] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs +genericTake _ _ = error "List.genericTake: negative argument" + +genericDrop :: (Integral i) => i -> [a] -> [a] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs +genericDrop _ _ = error "List.genericDrop: negative argument" + +genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where + (xs',xs'') = genericSplitAt (n-1) xs +genericSplitAt _ _ = error "List.genericSplitAt: negative argument" + + +genericIndex :: (Integral a) => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument." +genericIndex _ _ = error "List.genericIndex: index too large." + +genericReplicate :: (Integral i) => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) + + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [(a,b,c,d,e,f)] +zip6 = zipWith6 (,,,,,) + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [g] -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (,,,,,,) + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) -> + [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + + + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + + +-- group splits its list argument into a list of lists of equal, adjacent +-- elements. e.g., +-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"] +group :: (Eq a) => [a] -> [[a]] +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy _ [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- inits xs returns the list of initial segments of xs, shortest first. +-- e.g., inits "abc" == ["","a","ab","abc"] +inits :: [a] -> [[a]] +inits [] = [[]] +inits (x:xs) = [[]] ++ map (x:) (inits xs) + +-- tails xs returns the list of all final segments of xs, longest first. +-- e.g., tails "abc" == ["abc", "bc", "c",""] +tails :: [a] -> [[a]] +tails [] = [[]] +tails xxs@(_:xs) = xxs : tails xs + + +------------------------------------------------------------------------------ +-- Quick Sort algorithm taken from HBC's QSort library. + +sort :: (Ord a) => [a] -> [a] +sortBy :: (a -> a -> Ordering) -> [a] -> [a] + +#ifdef USE_REPORT_PRELUDE +sort = sortBy compare +sortBy cmp = foldr (insertBy cmp) [] +#else + +sortBy cmp l = qsort cmp l [] +sort l = qsort compare l [] + +-- rest is not exported: + +-- qsort is stable and does not concatenate. +qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +qsort _ [] r = r +qsort _ [x] r = x:r +qsort cmp (x:xs) r = qpart cmp x xs [] [] r + +-- qpart partitions and sorts the sublists +qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] +qpart cmp x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort cmp rlt (x:rqsort cmp rge r) +qpart cmp x (y:ys) rlt rge r = + case cmp x y of + GT -> qpart cmp x ys (y:rlt) rge r + _ -> qpart cmp x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +rqsort _ [] r = r +rqsort _ [x] r = x:r +rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r + +rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] +rqpart cmp x [] rle rgt r = + qsort cmp rle (x:qsort cmp rgt r) +rqpart cmp x (y:ys) rle rgt r = + case cmp y x of + GT -> rqpart cmp x ys rle (y:rgt) r + _ -> rqpart cmp x ys (y:rle) rgt r + +#endif /* USE_REPORT_PRELUDE */ + +{- +\begin{verbatim} + unfoldr f' (foldr f z xs) == (z,xs) + + if the following holds: + + f' (f x y) = Just (x,y) + f' z = Nothing +\end{verbatim} +-} + +unfoldr :: (b -> Maybe (a, b)) -> b -> [a] +unfoldr f b = + case f b of + Just (a,new_b) -> a : unfoldr f new_b + Nothing -> [] + +-- ----------------------------------------------------------------------------- +-- List sum and product + +-- sum and product compute the sum or product of a finite list of numbers. +{-# SPECIALISE sum :: [Int] -> Int #-} +{-# SPECIALISE sum :: [Integer] -> Integer #-} +{-# SPECIALISE product :: [Int] -> Int #-} +{-# SPECIALISE product :: [Integer] -> Integer #-} +sum, product :: (Num a) => [a] -> a +#ifdef USE_REPORT_PRELUDE +sum = foldl (+) 0 +product = foldl (*) 1 +#else +sum l = sum' l 0 + where + sum' [] a = a + sum' (x:xs) a = sum' xs (a+x) +product l = prod l 1 + where + prod [] a = a + prod (x:xs) a = prod xs (a*x) +#endif diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs new file mode 100644 index 0000000000..06c7a25398 --- /dev/null +++ b/libraries/base/Data/Maybe.hs @@ -0,0 +1,75 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.Maybe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Maybe.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The Maybe type, and associated operations. +-- +----------------------------------------------------------------------------- + +module Data.Maybe + ( + Maybe(Nothing,Just)-- instance of: Eq, Ord, Show, Read, + -- Functor, Monad, MonadPlus + + , maybe -- :: b -> (a -> b) -> Maybe a -> b + + , isJust -- :: Maybe a -> Bool + , isNothing -- :: Maybe a -> Bool + , fromJust -- :: Maybe a -> a + , fromMaybe -- :: a -> Maybe a -> a + , listToMaybe -- :: [a] -> Maybe a + , maybeToList -- :: Maybe a -> [a] + , catMaybes -- :: [Maybe a] -> [a] + , mapMaybe -- :: (a -> Maybe b) -> [a] -> [b] + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Err ( error ) +import GHC.List +import GHC.Maybe +import GHC.Base +#endif + +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust _ = True + +isNothing :: Maybe a -> Bool +isNothing Nothing = True +isNothing _ = False + +fromJust :: Maybe a -> a +fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck +fromJust (Just x) = x + +fromMaybe :: a -> Maybe a -> a +fromMaybe d x = case x of {Nothing -> d;Just v -> v} + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just x) = [x] + +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + +catMaybes :: [Maybe a] -> [a] +catMaybes ls = [x | Just x <- ls] + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe _ [] = [] +mapMaybe f (x:xs) = + let rs = mapMaybe f xs in + case f x of + Nothing -> rs + Just r -> r:rs + diff --git a/libraries/base/Data/PackedString.hs b/libraries/base/Data/PackedString.hs new file mode 100644 index 0000000000..6fc1a8f2be --- /dev/null +++ b/libraries/base/Data/PackedString.hs @@ -0,0 +1,914 @@ +{-# OPTIONS -#include "PackedString.h" #-} +----------------------------------------------------------------------------- +-- +-- Module : Data.PackedString +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: PackedString.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The PackedString type, and associated operations. +-- GHC implementation by Bryan O'Sullivan. +-- +----------------------------------------------------------------------------- + +module Data.PackedString ( + PackedString, -- abstract, instances: Eq, Ord, Show, Typeable + + -- Creating the beasts + packString, -- :: [Char] -> PackedString + packStringST, -- :: [Char] -> ST s PackedString + packCBytesST, -- :: Int -> Ptr a -> ST s PackedString + + byteArrayToPS, -- :: ByteArray Int -> PackedString + cByteArrayToPS, -- :: ByteArray Int -> PackedString + unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString + + psToByteArray, -- :: PackedString -> ByteArray Int + psToCString, -- :: PackedString -> Ptr a + isCString, -- :: PackedString -> Bool + + unpackPS, -- :: PackedString -> [Char] + unpackNBytesPS, -- :: PackedString -> Int -> [Char] + unpackPSIO, -- :: PackedString -> IO [Char] + + hPutPS, -- :: Handle -> PackedString -> IO () + hGetPS, -- :: Handle -> Int -> IO PackedString + + nilPS, -- :: PackedString + consPS, -- :: Char -> PackedString -> PackedString + headPS, -- :: PackedString -> Char + tailPS, -- :: PackedString -> PackedString + nullPS, -- :: PackedString -> Bool + appendPS, -- :: PackedString -> PackedString -> PackedString + lengthPS, -- :: PackedString -> Int + {- 0-origin indexing into the string -} + indexPS, -- :: PackedString -> Int -> Char + mapPS, -- :: (Char -> Char) -> PackedString -> PackedString + filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString + foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a + foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a + takePS, -- :: Int -> PackedString -> PackedString + dropPS, -- :: Int -> PackedString -> PackedString + splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString) + takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString + dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString + spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) + breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) + linesPS, -- :: PackedString -> [PackedString] + + wordsPS, -- :: PackedString -> [PackedString] + reversePS, -- :: PackedString -> PackedString + splitPS, -- :: Char -> PackedString -> [PackedString] + splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString] + joinPS, -- :: PackedString -> [PackedString] -> PackedString + concatPS, -- :: [PackedString] -> PackedString + elemPS, -- :: Char -> PackedString -> Bool + + {- + Pluck out a piece of a PS start and end + chars you want; both 0-origin-specified + -} + substrPS, -- :: PackedString -> Int -> Int -> PackedString + + comparePS -- :: PackedString -> PackedString -> Ordering + + ) where + +import Prelude + +import Foreign +import Foreign.C + +import GHC.Prim +import GHC.Base +import GHC.ST +import GHC.ByteArr + +import GHC.Show ( showList__ ) -- ToDo: better +import GHC.Pack ( new_ps_array, freeze_ps_array, write_ps_array ) + +import Control.Monad.ST + +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.IO ( hPutBufBA, hGetBufBA ) + +import Data.Ix +import Data.Char ( isSpace ) +import Data.Dynamic + +-- ----------------------------------------------------------------------------- +-- PackedString type declaration + +data PackedString + = PS ByteArray# -- the bytes + Int# -- length (*not* including NUL at the end) + Bool -- True <=> contains a NUL + | CPS Addr# -- pointer to the (null-terminated) bytes in C land + Int# -- length, as per strlen + -- definitely doesn't contain a NUL + +instance Eq PackedString where + x == y = compare x y == EQ + x /= y = compare x y /= EQ + +instance Ord PackedString where + compare = comparePS + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } + +--instance Read PackedString: ToDo + +instance Show PackedString where + showsPrec p ps r = showsPrec p (unpackPS ps) r + showList = showList__ (showsPrec 0) + +#include "Dynamic.h" +INSTANCE_TYPEABLE0(PackedString,packedStringTc,"PackedString") + +-- ----------------------------------------------------------------------------- +-- PackedString instances + +-- We try hard to make this go fast: + +comparePS :: PackedString -> PackedString -> Ordering + +comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2) + | not has_null1 && not has_null2 + = unsafePerformIO ( + _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT + )) + where + ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1 + ba2 = ByteArray 0 (I# (len2 -# 1#)) bs2 + +comparePS (PS bs1 len1 has_null1) (CPS bs2 _) + | not has_null1 + = unsafePerformIO ( + _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT + )) + where + ba1 = ByteArray 0 (I# (len1 -# 1#)) bs1 + ba2 = Ptr bs2 + +comparePS (CPS bs1 len1) (CPS bs2 _) + = unsafePerformIO ( + _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> + return ( + if res <# 0# then LT + else if res ==# 0# then EQ + else GT + )) + where + ba1 = Ptr bs1 + ba2 = Ptr bs2 + +comparePS a@(CPS _ _) b@(PS _ _ has_null2) + | not has_null2 + = -- try them the other way 'round + case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT } + +comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True) + = looking_at 0# + where + end1 = lengthPS# ps1 -# 1# + end2 = lengthPS# ps2 -# 1# + + looking_at char# + = if char# ># end1 then + if char# ># end2 then -- both strings ran out at once + EQ + else -- ps1 ran out before ps2 + LT + else if char# ># end2 then + GT -- ps2 ran out before ps1 + else + let + ch1 = indexPS# ps1 char# + ch2 = indexPS# ps2 char# + in + if ch1 `eqChar#` ch2 then + looking_at (char# +# 1#) + else if ch1 `ltChar#` ch2 then LT + else GT + + +-- ----------------------------------------------------------------------------- +-- Constructor functions + +-- Easy ones first. @packString@ requires getting some heap-bytes and +-- scribbling stuff into them. + +nilPS :: PackedString +nilPS = CPS ""# 0# + +consPS :: Char -> PackedString -> PackedString +consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better + +packString :: [Char] -> PackedString +packString str = runST (packStringST str) + +packStringST :: [Char] -> ST s PackedString +packStringST str = + let len = length str in + packNCharsST len str + +packNCharsST :: Int -> [Char] -> ST s PackedString +packNCharsST (I# length#) str = + {- + allocate an array that will hold the string + (not forgetting the NUL byte at the end) + -} + new_ps_array (length# +# 1#) >>= \ ch_array -> + -- fill in packed string from "str" + fill_in ch_array 0# str >> + -- freeze the puppy: + freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) -> + let has_null = byteArrayHasNUL# frozen# length# in + return (PS frozen# length# has_null) + where + fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s () + fill_in arr_in# idx [] = + write_ps_array arr_in# idx (chr# 0#) >> + return () + + fill_in arr_in# idx (C# c : cs) = + write_ps_array arr_in# idx c >> + fill_in arr_in# (idx +# 1#) cs + +byteArrayToPS :: ByteArray Int -> PackedString +byteArrayToPS (ByteArray l u frozen#) = + let + ixs = (l,u) + n# = + case ( + if null (range ixs) + then 0 + else ((index ixs u) + 1) + ) of { I# x -> x } + in + PS frozen# n# (byteArrayHasNUL# frozen# n#) + +-- byteArray is zero-terminated, make everything upto it +-- a packed string. +cByteArrayToPS :: ByteArray Int -> PackedString +cByteArrayToPS (ByteArray l u frozen#) = + let + ixs = (l,u) + n# = + case ( + if null (range ixs) + then 0 + else ((index ixs u) + 1) + ) of { I# x -> x } + len# = findNull 0# + + findNull i# + | i# ==# n# = n# + | ch# `eqChar#` '\0'# = i# -- everything upto the sentinel + | otherwise = findNull (i# +# 1#) + where + ch# = indexCharArray# frozen# i# + in + PS frozen# len# False + +unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString +unsafeByteArrayToPS (ByteArray _ _ frozen#) (I# n#) + = PS frozen# n# (byteArrayHasNUL# frozen# n#) + +psToByteArray :: PackedString -> ByteArray Int +psToByteArray (PS bytes n _) = ByteArray 0 (I# (n -# 1#)) bytes + +psToByteArray (CPS addr len#) + = let + len = I# len# + byte_array_form = packCBytes len (Ptr addr) + in + case byte_array_form of { PS bytes _ _ -> + ByteArray 0 (len - 1) bytes } + +-- isCString is useful when passing PackedStrings to the +-- outside world, and need to figure out whether you can +-- pass it as an Addr or ByteArray. +-- +isCString :: PackedString -> Bool +isCString (CPS _ _ ) = True +isCString _ = False + +-- psToCString doesn't add a zero terminator! +-- this doesn't appear to be very useful --SDM +psToCString :: PackedString -> Ptr a +psToCString (CPS addr _) = (Ptr addr) +psToCString (PS bytes l# _) = + unsafePerformIO $ do + stuff <- mallocBytes (I# (l# +# 1#)) + let + fill_in n# i# + | n# ==# 0# = return () + | otherwise = do + let ch# = indexCharArray# bytes i# + pokeByteOff stuff (I# i#) (castCharToCChar (C# ch#)) + fill_in (n# -# 1#) (i# +# 1#) + fill_in l# 0# + pokeByteOff stuff (I# l#) (C# '\0'#) + return stuff + +-- ----------------------------------------------------------------------------- +-- Destructor functions (taking PackedStrings apart) + +-- OK, but this code gets *hammered*: +-- unpackPS ps +-- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ] + +unpackPS :: PackedString -> [Char] +unpackPS (PS bytes len _) = unpack 0# + where + unpack nh + | nh >=# len = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharArray# bytes nh + +unpackPS (CPS addr _) = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +unpackNBytesPS :: PackedString -> Int -> [Char] +unpackNBytesPS ps len@(I# l#) + | len < 0 = error ("PackedString.unpackNBytesPS: negative length "++ show len) + | len == 0 = [] + | otherwise = + case ps of + PS bytes len# has_null -> unpackPS (PS bytes (min# len# l#) has_null) + CPS a len# -> unpackPS (CPS a (min# len# l#)) + where + min# x# y# + | x# <# y# = x# + | otherwise = y# + +unpackPSIO :: PackedString -> IO String +unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps) +unpackPSIO (CPS addr _) = unpack 0# + where + unpack nh = do + ch <- peekByteOff (Ptr addr) (I# nh) + let c = castCCharToChar ch + if c == '\0' + then return [] + else do + ls <- unpack (nh +# 1#) + return (c : ls) + +-- Output a packed string via a handle: + +hPutPS :: Handle -> PackedString -> IO () +hPutPS handle (CPS a# len#) = hPutBuf handle (Ptr a#) (I# len#) +hPutPS handle (PS ba# len# _) = do + let mba = MutableByteArray (bottom::Int) bottom (unsafeCoerce# ba#) + hPutBufBA handle mba (I# len#) + where + bottom = error "hPutPS" + +-- The dual to @_putPS@, note that the size of the chunk specified +-- is the upper bound of the size of the chunk returned. + +hGetPS :: Handle -> Int -> IO PackedString +hGetPS hdl len@(I# len#) + | len# <=# 0# = return nilPS -- I'm being kind here. + | otherwise = + -- Allocate an array for system call to store its bytes into. + stToIO (new_ps_array len# ) >>= \ ch_arr -> + stToIO (freeze_ps_array ch_arr len#) >>= \ (ByteArray _ _ frozen#) -> + hGetBufBA hdl ch_arr len >>= \ (I# read#) -> + if read# ==# 0# then -- EOF or other error + ioError (userError "hGetPS: EOF reached or other error") + else + {- + The system call may not return the number of + bytes requested. Instead of failing with an error + if the number of bytes read is less than requested, + a packed string containing the bytes we did manage + to snarf is returned. + -} + let + has_null = byteArrayHasNUL# frozen# read# + in + return (PS frozen# read# has_null) + +-- ----------------------------------------------------------------------------- +-- List-mimicking functions for PackedStrings + +-- First, the basic functions that do look into the representation; +-- @indexPS@ is the most important one. + +lengthPS :: PackedString -> Int +lengthPS ps = I# (lengthPS# ps) + +{-# INLINE lengthPS# #-} + +lengthPS# :: PackedString -> Int# +lengthPS# (PS _ i _) = i +lengthPS# (CPS _ i) = i + +{-# INLINE strlen# #-} + +strlen# :: Addr# -> Int +strlen# a + = unsafePerformIO ( + _ccall_ strlen (Ptr a) >>= \ len@(I# _) -> + return len + ) + +byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool +byteArrayHasNUL# bs len + = unsafePerformIO ( + _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) -> + return ( + if res ==# 0# then False else True + )) + where + ba = ByteArray 0 (I# (len -# 1#)) bs + +----------------------- + +indexPS :: PackedString -> Int -> Char +indexPS ps (I# n) = C# (indexPS# ps n) + +{-# INLINE indexPS# #-} + +indexPS# :: PackedString -> Int# -> Char# +indexPS# (PS bs i _) n + = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10) + indexCharArray# bs n + +indexPS# (CPS a _) n + = indexCharOffAddr# a n + +-- Now, the rest of the functions can be defined without digging +-- around in the representation. + +headPS :: PackedString -> Char +headPS ps + | nullPS ps = error "headPS: head []" + | otherwise = C# (indexPS# ps 0#) + +tailPS :: PackedString -> PackedString +tailPS ps + | len <=# 0# = error "tailPS: tail []" + | len ==# 1# = nilPS + | otherwise = substrPS# ps 1# (len -# 1#) + where + len = lengthPS# ps + +nullPS :: PackedString -> Bool +nullPS (PS _ i _) = i ==# 0# +nullPS (CPS _ i) = i ==# 0# + +appendPS :: PackedString -> PackedString -> PackedString +appendPS xs ys + | nullPS xs = ys + | nullPS ys = xs + | otherwise = concatPS [xs,ys] + +mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-} +mapPS f xs = + if nullPS xs then + xs + else + runST ( + new_ps_array (length +# 1#) >>= \ ps_arr -> + whizz ps_arr length 0# >> + freeze_ps_array ps_arr length >>= \ (ByteArray _ _ frozen#) -> + let has_null = byteArrayHasNUL# frozen# length in + return (PS frozen# length has_null)) + where + length = lengthPS# xs + + whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s () + whizz arr# n i + | n ==# 0# + = write_ps_array arr# i (chr# 0#) >> + return () + | otherwise + = let + ch = indexPS# xs i + in + write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >> + whizz arr# (n -# 1#) (i +# 1#) + +filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-} +filterPS pred ps = + if nullPS ps then + ps + else + {- + Filtering proceeds as follows: + + * traverse the list, applying the pred. to each element, + remembering the positions where it was satisfied. + + Encode these positions using a run-length encoding of the gaps + between the matching positions. + + * Allocate a MutableByteArray in the heap big enough to hold + all the matched entries, and copy the elements that matched over. + + A better solution that merges the scan© passes into one, + would be to copy the filtered elements over into a growable + buffer. No such operation currently supported over + MutableByteArrays (could of course use malloc&realloc) + But, this solution may in the case of repeated realloc's + be worse than the current solution. + -} + runST ( + let + (rle,len_filtered) = filter_ps (len# -# 1#) 0# 0# [] + len_filtered# = case len_filtered of { I# x# -> x#} + in + if len# ==# len_filtered# then + {- not much filtering as everything passed through. -} + return ps + else if len_filtered# ==# 0# then + return nilPS + else + new_ps_array (len_filtered# +# 1#) >>= \ ps_arr -> + copy_arr ps_arr rle 0# 0# >> + freeze_ps_array ps_arr len_filtered# >>= \ (ByteArray _ _ frozen#) -> + let has_null = byteArrayHasNUL# frozen# len_filtered# in + return (PS frozen# len_filtered# has_null)) + where + len# = lengthPS# ps + + matchOffset :: Int# -> [Char] -> (Int,[Char]) + matchOffset off [] = (I# off,[]) + matchOffset off (C# c:cs) = + let + x = ord# c + off' = off +# x + in + if x==# 0# then -- escape code, add 255# + matchOffset off' cs + else + (I# off', cs) + + copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s () + copy_arr _ [_] _ _ = return () + copy_arr arr# ls n i = + let + (x,ls') = matchOffset 0# ls + n' = n +# (case x of { (I# x#) -> x#}) -# 1# + ch = indexPS# ps n' + in + write_ps_array arr# i ch >> + copy_arr arr# ls' (n' +# 1#) (i +# 1#) + + esc :: Int# -> Int# -> [Char] -> [Char] + esc v 0# ls = (C# (chr# v)):ls + esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls) + + filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int) + filter_ps n hits run acc + | n <# 0# = + let + escs = run `quotInt#` 255# + v = run `remInt#` 255# + in + (esc (v +# 1#) escs acc, I# hits) + | otherwise + = let + ch = indexPS# ps n + n' = n -# 1# + in + if pred (C# ch) then + let + escs = run `quotInt#` 255# + v = run `remInt#` 255# + acc' = esc (v +# 1#) escs acc + in + filter_ps n' (hits +# 1#) 0# acc' + else + filter_ps n' hits (run +# 1#) acc + + +foldlPS :: (a -> Char -> a) -> a -> PackedString -> a +foldlPS f b ps + = if nullPS ps then + b + else + whizzLR b 0# + where + len = lengthPS# ps + + --whizzLR :: a -> Int# -> a + whizzLR b idx + | idx ==# len = b + | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#) + + +foldrPS :: (Char -> a -> a) -> a -> PackedString -> a +foldrPS f v ps + | nullPS ps = v + | otherwise = whizzRL v len + where + len = lengthPS# ps + + --whizzRL :: a -> Int# -> a + whizzRL b idx + | idx <# 0# = b + | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#) + +takePS :: Int -> PackedString -> PackedString +takePS (I# n) ps + | n ==# 0# = nilPS + | otherwise = substrPS# ps 0# (n -# 1#) + +dropPS :: Int -> PackedString -> PackedString +dropPS (I# n) ps + | n ==# len = nilPS + | otherwise = substrPS# ps n (lengthPS# ps -# 1#) + where + len = lengthPS# ps + +splitAtPS :: Int -> PackedString -> (PackedString, PackedString) +splitAtPS n ps = (takePS n ps, dropPS n ps) + +takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString +takeWhilePS pred ps + = let + break_pt = char_pos_that_dissatisfies + (\ c -> pred (C# c)) + ps + (lengthPS# ps) + 0# + in + if break_pt ==# 0# then + nilPS + else + substrPS# ps 0# (break_pt -# 1#) + +dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString +dropWhilePS pred ps + = let + len = lengthPS# ps + break_pt = char_pos_that_dissatisfies + (\ c -> pred (C# c)) + ps + len + 0# + in + if len ==# break_pt then + nilPS + else + substrPS# ps break_pt (len -# 1#) + +elemPS :: Char -> PackedString -> Bool +elemPS (C# ch) ps + = let + len = lengthPS# ps + break_pt = first_char_pos_that_satisfies + (`eqChar#` ch) + ps + len + 0# + in + break_pt <# len + +char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int# + +char_pos_that_dissatisfies p ps len pos + | pos >=# len = pos -- end + | p (indexPS# ps pos) = -- predicate satisfied; keep going + char_pos_that_dissatisfies p ps len (pos +# 1#) + | otherwise = pos -- predicate not satisfied + +first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int# +first_char_pos_that_satisfies p ps len pos + | pos >=# len = pos -- end + | p (indexPS# ps pos) = pos -- got it! + | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#) + +-- ToDo: could certainly go quicker +spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) +spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps) + +breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString) +breakPS p ps = spanPS (not . p) ps + +linesPS :: PackedString -> [PackedString] +linesPS ps = splitPS '\n' ps + +wordsPS :: PackedString -> [PackedString] +wordsPS ps = splitWithPS isSpace ps + +reversePS :: PackedString -> PackedString +reversePS ps = + if nullPS ps then -- don't create stuff unnecessarily. + ps + else + runST ( + new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte! + fill_in arr# (length -# 1#) 0# >> + freeze_ps_array arr# length >>= \ (ByteArray _ _ frozen#) -> + let has_null = byteArrayHasNUL# frozen# length in + return (PS frozen# length has_null)) + where + length = lengthPS# ps + + fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s () + fill_in arr_in# n i = + let + ch = indexPS# ps n + in + write_ps_array arr_in# i ch >> + if n ==# 0# then + write_ps_array arr_in# (i +# 1#) (chr# 0#) >> + return () + else + fill_in arr_in# (n -# 1#) (i +# 1#) + +concatPS :: [PackedString] -> PackedString +concatPS [] = nilPS +concatPS pss + = let + tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x } + in + runST ( + new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte! + packum arr# pss 0# >> + freeze_ps_array arr# tot_len# >>= \ (ByteArray _ _ frozen#) -> + + let has_null = byteArrayHasNUL# frozen# tot_len# in + + return (PS frozen# tot_len# has_null) + ) + where + packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s () + + packum arr [] pos + = write_ps_array arr pos (chr# 0#) >> + return () + packum arr (ps : pss) pos + = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) -> + packum arr pss next_pos + + fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int + + fill arr arr_i ps ps_i ps_len + | ps_i ==# ps_len + = return (I# (arr_i +# ps_len)) + | otherwise + = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >> + fill arr arr_i ps (ps_i +# 1#) ps_len + +------------------------------------------------------------ +joinPS :: PackedString -> [PackedString] -> PackedString +joinPS filler pss = concatPS (splice pss) + where + splice [] = [] + splice [x] = [x] + splice (x:y:xs) = x:filler:splice (y:xs) + +-- ToDo: the obvious generalisation +{- + Some properties that hold: + + * splitPS x ls = ls' + where False = any (map (x `elemPS`) ls') + False = any (map (nullPS) ls') + + * all x's have been chopped out. + * no empty PackedStrings in returned list. A conseq. + of this is: + splitPS x nilPS = [] + + + * joinPS (packString [x]) (_splitPS x ls) = ls + +-} + +splitPS :: Char -> PackedString -> [PackedString] +splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch) + +splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString] +splitWithPS pred ps = + splitify 0# + where + len = lengthPS# ps + + splitify n + | n >=# len = [] + | otherwise = + let + break_pt = + first_char_pos_that_satisfies + (\ c -> pred (C# c)) + ps + len + n + in + if break_pt ==# n then -- immediate match, no substring to cut out. + splitify (break_pt +# 1#) + else + substrPS# ps n (break_pt -# 1#): -- leave out the matching character + splitify (break_pt +# 1#) + +-- ----------------------------------------------------------------------------- +-- Local utility functions + +-- The definition of @_substrPS@ is essentially: +-- @take (end - begin + 1) (drop begin str)@. + +substrPS :: PackedString -> Int -> Int -> PackedString +substrPS ps (I# begin) (I# end) = substrPS# ps begin end + +substrPS# :: PackedString -> Int# -> Int# -> PackedString +substrPS# ps s e + | s <# 0# || s >=# len || result_len# <=# 0# + = nilPS + + | otherwise + = runST ( + new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte! + fill_in ch_arr 0# >> + freeze_ps_array ch_arr result_len# >>= \ (ByteArray _ _ frozen#) -> + + let has_null = byteArrayHasNUL# frozen# result_len# in + + return (PS frozen# result_len# has_null) + ) + where + len = lengthPS# ps + + result_len# = (if e <# len then (e +# 1#) else len) -# s + + ----------------------- + fill_in :: MutableByteArray s Int -> Int# -> ST s () + + fill_in arr_in# idx + | idx ==# result_len# + = write_ps_array arr_in# idx (chr# 0#) >> + return () + | otherwise + = let + ch = indexPS# ps (s +# idx) + in + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) + +-- ----------------------------------------------------------------------------- +-- Packing and unpacking C strings + +cStringToPS :: Ptr a -> PackedString +cStringToPS (Ptr a#) = -- the easy one; we just believe the caller + CPS a# len + where + len = case (strlen# a#) of { I# x -> x } + +packCBytes :: Int -> Ptr a -> PackedString +packCBytes len addr = runST (packCBytesST len addr) + +packCBytesST :: Int -> Ptr a -> ST s PackedString +packCBytesST (I# length#) (Ptr addr) = + {- + allocate an array that will hold the string + (not forgetting the NUL byte at the end) + -} + new_ps_array (length# +# 1#) >>= \ ch_array -> + -- fill in packed string from "addr" + fill_in ch_array 0# >> + -- freeze the puppy: + freeze_ps_array ch_array length# >>= \ (ByteArray _ _ frozen#) -> + let has_null = byteArrayHasNUL# frozen# length# in + return (PS frozen# length# has_null) + where + fill_in :: MutableByteArray s Int -> Int# -> ST s () + + fill_in arr_in# idx + | idx ==# length# + = write_ps_array arr_in# idx (chr# 0#) >> + return () + | otherwise + = case (indexCharOffAddr# addr idx) of { ch -> + write_ps_array arr_in# idx ch >> + fill_in arr_in# (idx +# 1#) } diff --git a/libraries/base/Data/Ratio.hs b/libraries/base/Data/Ratio.hs new file mode 100644 index 0000000000..42426ce703 --- /dev/null +++ b/libraries/base/Data/Ratio.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.Ratio +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Ratio.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Standard functions on rational numbers +-- +----------------------------------------------------------------------------- + +module Data.Ratio + ( Ratio + , Rational + , (%) -- :: (Integral a) => a -> a -> Ratio a + , numerator -- :: (Integral a) => Ratio a -> a + , denominator -- :: (Integral a) => Ratio a -> a + , approxRational -- :: (RealFrac a) => a -> a -> Rational + + -- Ratio instances: + -- (Integral a) => Eq (Ratio a) + -- (Integral a) => Ord (Ratio a) + -- (Integral a) => Num (Ratio a) + -- (Integral a) => Real (Ratio a) + -- (Integral a) => Fractional (Ratio a) + -- (Integral a) => RealFrac (Ratio a) + -- (Integral a) => Enum (Ratio a) + -- (Read a, Integral a) => Read (Ratio a) + -- (Integral a) => Show (Ratio a) + + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.Real -- The basic defns for Ratio +#endif + +-- ----------------------------------------------------------------------------- +-- approxRational + +-- @approxRational@, applied to two real fractional numbers x and epsilon, +-- returns the simplest rational number within epsilon of x. A rational +-- number n%d in reduced form is said to be simpler than another n'%d' if +-- abs n <= abs n' && d <= d'. Any real interval contains a unique +-- simplest rational; here, for simplicity, we assume a closed rational +-- interval. If such an interval includes at least one whole number, then +-- the simplest rational is the absolutely least whole number. Otherwise, +-- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +-- and abs r' < d', and the simplest rational is q%1 + the reciprocal of +-- the simplest rational between d'%r' and d%r. + +approxRational :: (RealFrac a) => a -> a -> Rational +approxRational rat eps = simplest (rat-eps) (rat+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' + diff --git a/libraries/base/Data/STRef.hs b/libraries/base/Data/STRef.hs new file mode 100644 index 0000000000..01e5cb0fa6 --- /dev/null +++ b/libraries/base/Data/STRef.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- +-- Module : Data.STRef +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: STRef.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Mutable references in the ST monad. +-- +----------------------------------------------------------------------------- + +module Data.STRef ( + STRef, -- abstract, instance Eq + newSTRef, -- :: a -> ST s (STRef s a) + readSTRef, -- :: STRef s a -> ST s a + writeSTRef -- :: STRef s a -> a -> ST s () + ) where + +import Prelude + +#ifdef __GLASGOW_HASKELL__ +import GHC.STRef +#endif + +import Data.Dynamic + +#include "Dynamic.h" +INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") diff --git a/libraries/base/Data/Word.hs b/libraries/base/Data/Word.hs new file mode 100644 index 0000000000..7fbdc87ebb --- /dev/null +++ b/libraries/base/Data/Word.hs @@ -0,0 +1,38 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Word.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- Sized unsigned integer types. +-- +----------------------------------------------------------------------------- + +module Data.Word + ( Word + , Word8 + , Word16 + , Word32 + , Word64 + -- instances: Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read, + -- Show, Bits, CCallable, CReturnable (last two are GHC specific.) + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.Word +#endif + +import Data.Dynamic + +#include "Dynamic.h" +INSTANCE_TYPEABLE0(Word8,word8Tc, "Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") diff --git a/libraries/base/Debug/Trace.hs b/libraries/base/Debug/Trace.hs new file mode 100644 index 0000000000..d5a012a73b --- /dev/null +++ b/libraries/base/Debug/Trace.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- +-- Module : Debug.Trace +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- $Id: Trace.hs,v 1.1 2001/06/28 14:15:02 simonmar Exp $ +-- +-- The trace function. +-- +----------------------------------------------------------------------------- + +module Debug.Trace ( + trace -- :: String -> a -> a + ) where + +import Prelude +import System.IO.Unsafe +import System.IO + +#ifdef __GLASGOW_HASKELL__ +import GHC.IOBase +import GHC.Handle +#endif + +#ifdef __GLASGOW_HASKELL__ +{-# NOINLINE trace #-} +trace :: String -> a -> a +trace string expr = unsafePerformIO $ do + hPutStr stderr string + hPutChar stderr '\n' + fd <- withHandle_ "trace" stderr $ (return.haFD) + postTraceHook fd + return expr + +foreign import "PostTraceHook" postTraceHook :: Int -> IO () +#endif diff --git a/libraries/base/Foreign.hs b/libraries/base/Foreign.hs new file mode 100644 index 0000000000..75639e4ed7 --- /dev/null +++ b/libraries/base/Foreign.hs @@ -0,0 +1,44 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Foreign +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Foreign.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $ +-- +-- A collection of data types, classes, and functions for interfacing +-- with another programming language. This is only a convenience module +-- in the future, but currently it has the additional task of hiding +-- those entities exported from other modules, which are not part of the +-- FFI proposal. +-- +----------------------------------------------------------------------------- + +module Foreign + ( module Data.Int + , module Data.Word + , module Foreign.Ptr + , module Foreign.ForeignPtr + , module Foreign.StablePtr + , module Foreign.Storable + , module Foreign.Marshal.Alloc + , module Foreign.Marshal.Array + , module Foreign.Marshal.Error + , module Foreign.Marshal.Utils + ) where + +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.StablePtr +import Foreign.Storable +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Error +import Foreign.Marshal.Utils diff --git a/libraries/base/Foreign/C.hs b/libraries/base/Foreign/C.hs new file mode 100644 index 0000000000..b91d6d79ce --- /dev/null +++ b/libraries/base/Foreign/C.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -fno-implicit-prelude #-} +----------------------------------------------------------------------------- +-- +-- Module : Foreign.C +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: C.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +-- +-- Bundles the C specific FFI library functionality +-- +----------------------------------------------------------------------------- + +module Foreign.C + ( module Foreign.C.Types + , module Foreign.C.TypesISO + , module Foreign.C.String + , module Foreign.C.Error + ) where + +import Foreign.C.Types +import Foreign.C.TypesISO +import Foreign.C.String +import Foreign.C.Error diff --git a/libraries/base/Foreign/C/Error.hs b/libraries/base/Foreign/C/Error.hs new file mode 100644 index 0000000000..3bba4ed55a --- /dev/null +++ b/libraries/base/Foreign/C/Error.hs @@ -0,0 +1,514 @@ +{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-} +----------------------------------------------------------------------------- +-- +-- Module : Foreign.C.Error +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/core/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- $Id: Error.hs,v 1.1 2001/06/28 14:15:03 simonmar Exp $ +-- +-- C-specific Marshalling support: Handling of C "errno" error codes +-- +----------------------------------------------------------------------------- + +module Foreign.C.Error ( + + -- Haskell representation for "errno" values + -- + Errno(..), -- instance: Eq + eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, + eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, + eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, + eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, + eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, + eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, + eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, + eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, + eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, + eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, + ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, + eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, + eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, + eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, + -- :: Errno + isValidErrno, -- :: Errno -> Bool + + -- access to the current thread's "errno" value + -- + getErrno, -- :: IO Errno + resetErrno, -- :: IO () + + -- conversion of an "errno" value into IO error + -- + errnoToIOError, -- :: String -- location + -- -> Errno -- errno + -- -> Maybe Handle -- handle + -- -> Maybe String -- filename + -- -> IOError + + -- throw current "errno" value + -- + throwErrno, -- :: String -> IO a + + -- guards for IO operations that may fail + -- + throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a + throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO () + throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a + throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO () + throwErrnoIfMinus1, -- :: Num a + -- => String -> IO a -> IO a + throwErrnoIfMinus1_, -- :: Num a + -- => String -> IO a -> IO () + throwErrnoIfMinus1Retry, + -- :: Num a + -- => String -> IO a -> IO a + throwErrnoIfMinus1Retry_, + -- :: Num a + -- => String -> IO a -> IO () + throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) + throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a) + + throwErrnoIfRetryMayBlock, + throwErrnoIfRetryMayBlock_, + throwErrnoIfMinus1RetryMayBlock, + throwErrnoIfMinus1RetryMayBlock_, + throwErrnoIfNullRetryMayBlock +) where + + +-- this is were we get the CCONST_XXX definitions from that configure +-- calculated for us +-- +#include "config.h" + +-- system dependent imports +-- ------------------------ + +-- GHC allows us to get at the guts inside IO errors/exceptions +-- +#if __GLASGOW_HASKELL__ +import GHC.IOBase (Exception(..), IOException(..), IOErrorType(..)) +#endif /* __GLASGOW_HASKELL__ */ + + +-- regular imports +-- --------------- + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal.Error ( void ) +import Data.Maybe + +#if __GLASGOW_HASKELL__ +import GHC.Storable +import GHC.IOBase +import GHC.Num +import GHC.Base +#else +import System.IO ( IOError, Handle, ioError ) +#endif + +-- "errno" type +-- ------------ + +-- import of C function that gives address of errno +-- +foreign import "ghcErrno" unsafe _errno :: Ptr CInt + +-- Haskell representation for "errno" values +-- +newtype Errno = Errno CInt + +instance Eq Errno where + errno1@(Errno no1) == errno2@(Errno no2) + | isValidErrno errno1 && isValidErrno errno2 = no1 == no2 + | otherwise = False + +-- common "errno" symbols +-- +eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, + eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, + eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, + eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, + eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, + eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, + eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, + eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, + eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, + eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, + ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, + eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, + eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, + eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno +-- +-- the CCONST_XXX identifiers are cpp symbols whose value is computed by +-- configure +-- +eOK = Errno 0 +e2BIG = Errno (CCONST_E2BIG) +eACCES = Errno (CCONST_EACCES) +eADDRINUSE = Errno (CCONST_EADDRINUSE) +eADDRNOTAVAIL = Errno (CCONST_EADDRNOTAVAIL) +eADV = Errno (CCONST_EADV) +eAFNOSUPPORT = Errno (CCONST_EAFNOSUPPORT) +eAGAIN = Errno (CCONST_EAGAIN) +eALREADY = Errno (CCONST_EALREADY) +eBADF = Errno (CCONST_EBADF) +eBADMSG = Errno (CCONST_EBADMSG) +eBADRPC = Errno (CCONST_EBADRPC) +eBUSY = Errno (CCONST_EBUSY) +eCHILD = Errno (CCONST_ECHILD) +eCOMM = Errno (CCONST_ECOMM) +eCONNABORTED = Errno (CCONST_ECONNABORTED) +eCONNREFUSED = Errno (CCONST_ECONNREFUSED) +eCONNRESET = Errno (CCONST_ECONNRESET) +eDEADLK = Errno (CCONST_EDEADLK) +eDESTADDRREQ = Errno (CCONST_EDESTADDRREQ) +eDIRTY = Errno (CCONST_EDIRTY) +eDOM = Errno (CCONST_EDOM) +eDQUOT = Errno (CCONST_EDQUOT) +eEXIST = Errno (CCONST_EEXIST) +eFAULT = Errno (CCONST_EFAULT) +eFBIG = Errno (CCONST_EFBIG) +eFTYPE = Errno (CCONST_EFTYPE) +eHOSTDOWN = Errno (CCONST_EHOSTDOWN) +eHOSTUNREACH = Errno (CCONST_EHOSTUNREACH) +eIDRM = Errno (CCONST_EIDRM) +eILSEQ = Errno (CCONST_EILSEQ) +eINPROGRESS = Errno (CCONST_EINPROGRESS) +eINTR = Errno (CCONST_EINTR) +eINVAL = Errno (CCONST_EINVAL) +eIO = Errno (CCONST_EIO) +eISCONN = Errno (CCONST_EISCONN) +eISDIR = Errno (CCONST_EISDIR) +eLOOP = Errno (CCONST_ELOOP) +eMFILE = Errno (CCONST_EMFILE) +eMLINK = Errno (CCONST_EMLINK) +eMSGSIZE = Errno (CCONST_EMSGSIZE) +eMULTIHOP = Errno (CCONST_EMULTIHOP) +eNAMETOOLONG = Errno (CCONST_ENAMETOOLONG) +eNETDOWN = Errno (CCONST_ENETDOWN) +eNETRESET = Errno (CCONST_ENETRESET) +eNETUNREACH = Errno (CCONST_ENETUNREACH) +eNFILE = Errno (CCONST_ENFILE) +eNOBUFS = Errno (CCONST_ENOBUFS) +eNODATA = Errno (CCONST_ENODATA) +eNODEV = Errno (CCONST_ENODEV) +eNOENT = Errno (CCONST_ENOENT) +eNOEXEC = Errno (CCONST_ENOEXEC) +eNOLCK = Errno (CCONST_ENOLCK) +eNOLINK = Errno (CCONST_ENOLINK) +eNOMEM = Errno (CCONST_ENOMEM) +eNOMSG = Errno (CCONST_ENOMSG) +eNONET = Errno (CCONST_ENONET) +eNOPROTOOPT = Errno (CCONST_ENOPROTOOPT) +eNOSPC = Errno (CCONST_ENOSPC) +eNOSR = Errno (CCONST_ENOSR) +eNOSTR = Errno (CCONST_ENOSTR) +eNOSYS = Errno (CCONST_ENOSYS) +eNOTBLK = Errno (CCONST_ENOTBLK) +eNOTCONN = Errno (CCONST_ENOTCONN) +eNOTDIR = Errno (CCONST_ENOTDIR) +eNOTEMPTY = Errno (CCONST_ENOTEMPTY) +eNOTSOCK = Errno (CCONST_ENOTSOCK) +eNOTTY = Errno (CCONST_ENOTTY) +eNXIO = Errno (CCONST_ENXIO) +eOPNOTSUPP = Errno (CCONST_EOPNOTSUPP) +ePERM = Errno (CCONST_EPERM) +ePFNOSUPPORT = Errno (CCONST_EPFNOSUPPORT) +ePIPE = Errno (CCONST_EPIPE) +ePROCLIM = Errno (CCONST_EPROCLIM) +ePROCUNAVAIL = Errno (CCONST_EPROCUNAVAIL) +ePROGMISMATCH = Errno (CCONST_EPROGMISMATCH) +ePROGUNAVAIL = Errno (CCONST_EPROGUNAVAIL) +ePROTO = Errno (CCONST_EPROTO) +ePROTONOSUPPORT = Errno (CCONST_EPROTONOSUPPORT) +ePROTOTYPE = Errno (CCONST_EPROTOTYPE) +eRANGE = Errno (CCONST_ERANGE) +eREMCHG = Errno (CCONST_EREMCHG) +eREMOTE = Errno (CCONST_EREMOTE) +eROFS = Errno (CCONST_EROFS) +eRPCMISMATCH = Errno (CCONST_ERPCMISMATCH) +eRREMOTE = Errno (CCONST_ERREMOTE) +eSHUTDOWN = Errno (CCONST_ESHUTDOWN) +eSOCKTNOSUPPORT = Errno (CCONST_ESOCKTNOSUPPORT) +eSPIPE = Errno (CCONST_ESPIPE) +eSRCH = Errno (CCONST_ESRCH) +eSRMNT = Errno (CCONST_ESRMNT) +eSTALE = Errno (CCONST_ESTALE) +eTIME = Errno (CCONST_ETIME) +eTIMEDOUT = Errno (CCONST_ETIMEDOUT) +eTOOMANYREFS = Errno (CCONST_ETOOMANYREFS) +eTXTBSY = Errno (CCONST_ETXTBSY) +eUSERS = Errno (CCONST_EUSERS) +eWOULDBLOCK = Errno (CCONST_EWOULDBLOCK) +eXDEV = Errno (CCONST_EXDEV) + +-- checks whether the given errno value is supported on the current +-- architecture +-- +isValidErrno :: Errno -> Bool +-- +-- the configure script sets all invalid "errno"s to -1 +-- +isValidErrno (Errno errno) = errno /= -1 + + +-- access to the current thread's "errno" value +-- -------------------------------------------- + +-- yield the current thread's "errno" value +-- +getErrno :: IO Errno +getErrno = do e <- peek _errno; return (Errno e) + +-- set the current thread's "errno" value to 0 +-- +resetErrno :: IO () +resetErrno = poke _errno 0 + + +-- throw current "errno" value +-- --------------------------- + +-- the common case: throw an IO error based on a textual description +-- of the error location and the current thread's "errno" value +-- +throwErrno :: String -> IO a +throwErrno loc = + do + errno <- getErrno + ioError (errnoToIOError loc errno Nothing Nothing) + + +-- guards for IO operations that may fail +-- -------------------------------------- + +-- guard an IO operation and throw an "errno" based exception of the result +-- value of the IO operation meets the given predicate +-- +throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a +throwErrnoIf pred loc f = + do + res <- f + if pred res then throwErrno loc else return res + +-- as `throwErrnoIf', but discards the result +-- +throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f + +-- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose +-- flag `EINTR') +-- +throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a +throwErrnoIfRetry pred loc f = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetry pred loc f + else throwErrno loc + else return res + +-- as `throwErrnoIfRetry', but checks for operations that would block and +-- executes an alternative action in that case. + +throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a +throwErrnoIfRetryMayBlock pred loc f on_block = + do + res <- f + if pred res + then do + err <- getErrno + if err == eINTR + then throwErrnoIfRetryMayBlock pred loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block + else throwErrno loc + else return res + +-- as `throwErrnoIfRetry', but discards the result +-- +throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () +throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f + +-- as `throwErrnoIfRetryMayBlock', but discards the result +-- +throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () +throwErrnoIfRetryMayBlock_ pred loc f on_block + = void $ throwErrnoIfRetryMayBlock pred loc f on_block + +-- throws "errno" if a result of "-1" is returned +-- +throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1 = throwErrnoIf (== -1) + +-- as `throwErrnoIfMinus1', but discards the result +-- +throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO () +throwErrnoIfMinus1_ = throwErrnoIf_ (== -1) + +-- throws "errno" if a result of "-1" is returned, but retries in case of an +-- interrupted operation +-- +throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) + +-- as `throwErrnoIfMinus1', but discards the result +-- +throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO () +throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) + +-- as throwErrnoIfMinus1Retry, but checks for operations that would block +-- +throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a +throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1) + +-- as `throwErrnoIfMinus1RetryMayBlock', but discards the result +-- +throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO () +throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1) + +-- throws "errno" if a result of a NULL pointer is returned +-- +throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNull = throwErrnoIf (== nullPtr) + +-- throws "errno" if a result of a NULL pointer is returned, but retries in +-- case of an interrupted operation +-- +throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a) +throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) + +-- as throwErrnoIfNullRetry, but checks for operations that would block +-- +throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a) +throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr) + +-- conversion of an "errno" value into IO error +-- -------------------------------------------- + +-- convert a location string, an "errno" value, an optional handle, +-- and an optional filename into a matching IO error +-- +errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError +errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do + str <- strerror errno >>= peekCString +#if __GLASGOW_HASKELL__ + return (IOException (IOError maybeHdl errType loc str maybeName)) + where + errType + | errno == eOK = OtherError + | errno == e2BIG = ResourceExhausted + | errno == eACCES = PermissionDenied + | errno == eADDRINUSE = ResourceBusy + | errno == eADDRNOTAVAIL = UnsupportedOperation + | errno == eADV = OtherError + | errno == eAFNOSUPPORT = UnsupportedOperation + | errno == eAGAIN = ResourceExhausted + | errno == eALREADY = AlreadyExists + | errno == eBADF = OtherError + | errno == eBADMSG = InappropriateType + | errno == eBADRPC = OtherError + | errno == eBUSY = ResourceBusy + | errno == eCHILD = NoSuchThing + | errno == eCOMM = ResourceVanished + | errno == eCONNABORTED = OtherError + | errno == eCONNREFUSED = NoSuchThing + | errno == eCONNRESET = ResourceVanished + | errno == eDEADLK = ResourceBusy + | errno == eDESTADDRREQ = InvalidArgument + | errno == eDIRTY = UnsatisfiedConstraints + | errno == eDOM = InvalidArgument + | errno == eDQUOT = PermissionDenied + | errno == eEXIST = AlreadyExists + | errno == eFAULT = OtherError + | 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) diff --git a/libraries/base/Foreign/C/String.hs b/libraries/base/Foreign/C/String.hs new file mode 100644 index 0000000000..eddf5ab7d7 --- /dev/null +++ b/libraries/base/Foreign/C/String.hs @@ -0,0 +1,179 @@ +{-# 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 diff --git a/libraries/base/Foreign/C/Types.hs b/libraries/base/Foreign/C/Types.hs new file mode 100644 index 0000000000..f20967299d --- /dev/null +++ b/libraries/base/Foreign/C/Types.hs @@ -0,0 +1,114 @@ +{-# 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") diff --git a/libraries/base/Foreign/C/TypesISO.hs b/libraries/base/Foreign/C/TypesISO.hs new file mode 100644 index 0000000000..3d971f1e72 --- /dev/null +++ b/libraries/base/Foreign/C/TypesISO.hs @@ -0,0 +1,84 @@ +{-# 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") diff --git a/libraries/base/Foreign/ForeignPtr.hs b/libraries/base/Foreign/ForeignPtr.hs new file mode 100644 index 0000000000..64313cf76d --- /dev/null +++ b/libraries/base/Foreign/ForeignPtr.hs @@ -0,0 +1,88 @@ +{-# 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 + diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs new file mode 100644 index 0000000000..ed16c0167d --- /dev/null +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -0,0 +1,115 @@ +{-# 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 () diff --git a/libraries/base/Foreign/Marshal/Array.hs b/libraries/base/Foreign/Marshal/Array.hs new file mode 100644 index 0000000000..cddd0585ef --- /dev/null +++ b/libraries/base/Foreign/Marshal/Array.hs @@ -0,0 +1,268 @@ +{-# 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) diff --git a/libraries/base/Foreign/Marshal/Error.hs b/libraries/base/Foreign/Marshal/Error.hs new file mode 100644 index 0000000000..c896ce24bc --- /dev/null +++ b/libraries/base/Foreign/Marshal/Error.hs @@ -0,0 +1,81 @@ +{-# 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 () diff --git a/libraries/base/Foreign/Marshal/Utils.hs b/libraries/base/Foreign/Marshal/Utils.hs new file mode 100644 index 0000000000..3ae9e066da --- /dev/null +++ b/libraries/base/Foreign/Marshal/Utils.hs @@ -0,0 +1,168 @@ +{-# 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 () diff --git a/libraries/base/Foreign/Ptr.hs b/libraries/base/Foreign/Ptr.hs new file mode 100644 index 0000000000..d7f9cb0cde --- /dev/null +++ b/libraries/base/Foreign/Ptr.hs @@ -0,0 +1,55 @@ +{-# 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") diff --git a/libraries/base/Foreign/StablePtr.hs b/libraries/base/Foreign/StablePtr.hs new file mode 100644 index 0000000000..5b94104432 --- /dev/null +++ b/libraries/base/Foreign/StablePtr.hs @@ -0,0 +1,35 @@ +{-# 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") diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs new file mode 100644 index 0000000000..118a1a35f8 --- /dev/null +++ b/libraries/base/Foreign/Storable.hs @@ -0,0 +1,33 @@ +{-# 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 diff --git a/libraries/base/GHC/Arr.lhs b/libraries/base/GHC/Arr.lhs new file mode 100644 index 0000000000..940b60334f --- /dev/null +++ b/libraries/base/GHC/Arr.lhs @@ -0,0 +1,574 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs new file mode 100644 index 0000000000..b07bbb2c7d --- /dev/null +++ b/libraries/base/GHC/Base.lhs @@ -0,0 +1,761 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/ByteArr.lhs b/libraries/base/GHC/ByteArr.lhs new file mode 100644 index 0000000000..49756fa761 --- /dev/null +++ b/libraries/base/GHC/ByteArr.lhs @@ -0,0 +1,184 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Conc.lhs b/libraries/base/GHC/Conc.lhs new file mode 100644 index 0000000000..57daaf8cfa --- /dev/null +++ b/libraries/base/GHC/Conc.lhs @@ -0,0 +1,202 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Dynamic.lhs b/libraries/base/GHC/Dynamic.lhs new file mode 100644 index 0000000000..1cd8675dd3 --- /dev/null +++ b/libraries/base/GHC/Dynamic.lhs @@ -0,0 +1,35 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Enum.lhs b/libraries/base/GHC/Enum.lhs new file mode 100644 index 0000000000..3a24c55672 --- /dev/null +++ b/libraries/base/GHC/Enum.lhs @@ -0,0 +1,414 @@ +% ----------------------------------------------------------------------------- +% $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} + diff --git a/libraries/base/GHC/Err.hi-boot b/libraries/base/GHC/Err.hi-boot new file mode 100644 index 0000000000..258f46e367 --- /dev/null +++ b/libraries/base/GHC/Err.hi-boot @@ -0,0 +1,12 @@ +--------------------------------------------------------------------------- +-- 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; + diff --git a/libraries/base/GHC/Err.lhs b/libraries/base/GHC/Err.lhs new file mode 100644 index 0000000000..c1aa78fa4f --- /dev/null +++ b/libraries/base/GHC/Err.lhs @@ -0,0 +1,129 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Exception.lhs b/libraries/base/GHC/Exception.lhs new file mode 100644 index 0000000000..abf9a82938 --- /dev/null +++ b/libraries/base/GHC/Exception.lhs @@ -0,0 +1,123 @@ +% ------------------------------------------------------------------------------ +% $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} + + diff --git a/libraries/base/GHC/Float.lhs b/libraries/base/GHC/Float.lhs new file mode 100644 index 0000000000..186d29c427 --- /dev/null +++ b/libraries/base/GHC/Float.lhs @@ -0,0 +1,892 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Handle.hsc b/libraries/base/GHC/Handle.hsc new file mode 100644 index 0000000000..c613d43af2 --- /dev/null +++ b/libraries/base/GHC/Handle.hsc @@ -0,0 +1,1191 @@ +{-# 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 diff --git a/libraries/base/GHC/IO.hsc b/libraries/base/GHC/IO.hsc new file mode 100644 index 0000000000..49046f9785 --- /dev/null +++ b/libraries/base/GHC/IO.hsc @@ -0,0 +1,787 @@ +{-# 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) diff --git a/libraries/base/GHC/IOBase.lhs b/libraries/base/GHC/IOBase.lhs new file mode 100644 index 0000000000..7e77363424 --- /dev/null +++ b/libraries/base/GHC/IOBase.lhs @@ -0,0 +1,605 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Int.lhs b/libraries/base/GHC/Int.lhs new file mode 100644 index 0000000000..c091d6759e --- /dev/null +++ b/libraries/base/GHC/Int.lhs @@ -0,0 +1,599 @@ +% +% (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} diff --git a/libraries/base/GHC/List.lhs b/libraries/base/GHC/List.lhs new file mode 100644 index 0000000000..c054bdb3d4 --- /dev/null +++ b/libraries/base/GHC/List.lhs @@ -0,0 +1,610 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Main.lhs b/libraries/base/GHC/Main.lhs new file mode 100644 index 0000000000..6f05dae14a --- /dev/null +++ b/libraries/base/GHC/Main.lhs @@ -0,0 +1,24 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Maybe.lhs b/libraries/base/GHC/Maybe.lhs new file mode 100644 index 0000000000..2a8189c82d --- /dev/null +++ b/libraries/base/GHC/Maybe.lhs @@ -0,0 +1,64 @@ +% ------------------------------------------------------------------------------ +% $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} + + + + diff --git a/libraries/base/GHC/Num.hi-boot b/libraries/base/GHC/Num.hi-boot new file mode 100644 index 0000000000..33298fdbd7 --- /dev/null +++ b/libraries/base/GHC/Num.hi-boot @@ -0,0 +1,14 @@ +--------------------------------------------------------------------------- +-- 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 ; diff --git a/libraries/base/GHC/Num.lhs b/libraries/base/GHC/Num.lhs new file mode 100644 index 0000000000..c835531488 --- /dev/null +++ b/libraries/base/GHC/Num.lhs @@ -0,0 +1,447 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Pack.lhs b/libraries/base/GHC/Pack.lhs new file mode 100644 index 0000000000..1b4e56ab42 --- /dev/null +++ b/libraries/base/GHC/Pack.lhs @@ -0,0 +1,231 @@ +% ------------------------------------------------------------------------------ +% $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} + + diff --git a/libraries/base/GHC/Posix.hsc b/libraries/base/GHC/Posix.hsc new file mode 100644 index 0000000000..b0adbe44fe --- /dev/null +++ b/libraries/base/GHC/Posix.hsc @@ -0,0 +1,295 @@ +{-# 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 diff --git a/libraries/base/GHC/Prim.hi-boot b/libraries/base/GHC/Prim.hi-boot new file mode 100644 index 0000000000..9028566698 --- /dev/null +++ b/libraries/base/GHC/Prim.hi-boot @@ -0,0 +1,441 @@ +--------------------------------------------------------------------------- +-- 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)} ; diff --git a/libraries/base/GHC/Ptr.lhs b/libraries/base/GHC/Ptr.lhs new file mode 100644 index 0000000000..61b7f3e2e0 --- /dev/null +++ b/libraries/base/GHC/Ptr.lhs @@ -0,0 +1,61 @@ +----------------------------------------------------------------------------- +-- $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} diff --git a/libraries/base/GHC/Read.lhs b/libraries/base/GHC/Read.lhs new file mode 100644 index 0000000000..1e66f85a96 --- /dev/null +++ b/libraries/base/GHC/Read.lhs @@ -0,0 +1,608 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Real.lhs b/libraries/base/GHC/Real.lhs new file mode 100644 index 0000000000..b453f6b6eb --- /dev/null +++ b/libraries/base/GHC/Real.lhs @@ -0,0 +1,369 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/ST.lhs b/libraries/base/GHC/ST.lhs new file mode 100644 index 0000000000..f98b33d73d --- /dev/null +++ b/libraries/base/GHC/ST.lhs @@ -0,0 +1,127 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/STRef.lhs b/libraries/base/GHC/STRef.lhs new file mode 100644 index 0000000000..cf9cea5efe --- /dev/null +++ b/libraries/base/GHC/STRef.lhs @@ -0,0 +1,30 @@ +\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} diff --git a/libraries/base/GHC/Show.lhs b/libraries/base/GHC/Show.lhs new file mode 100644 index 0000000000..2edd0383de --- /dev/null +++ b/libraries/base/GHC/Show.lhs @@ -0,0 +1,378 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Stable.lhs b/libraries/base/GHC/Stable.lhs new file mode 100644 index 0000000000..691fe6c52f --- /dev/null +++ b/libraries/base/GHC/Stable.lhs @@ -0,0 +1,54 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/Storable.lhs b/libraries/base/GHC/Storable.lhs new file mode 100644 index 0000000000..e340a8ee88 --- /dev/null +++ b/libraries/base/GHC/Storable.lhs @@ -0,0 +1,289 @@ +% ----------------------------------------------------------------------------- +% $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} diff --git a/libraries/base/GHC/TopHandler.lhs b/libraries/base/GHC/TopHandler.lhs new file mode 100644 index 0000000000..18e807ae3c --- /dev/null +++ b/libraries/base/GHC/TopHandler.lhs @@ -0,0 +1,85 @@ +-- ----------------------------------------------------------------------------- +-- $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} diff --git a/libraries/base/GHC/Tup.lhs b/libraries/base/GHC/Tup.lhs new file mode 100644 index 0000000000..5e3de77f89 --- /dev/null +++ b/libraries/base/GHC/Tup.lhs @@ -0,0 +1,238 @@ +% ----------------------------------------------------------------------------- +% $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} + diff --git a/libraries/base/GHC/Weak.lhs b/libraries/base/GHC/Weak.lhs new file mode 100644 index 0000000000..b9e5172bf0 --- /dev/null +++ b/libraries/base/GHC/Weak.lhs @@ -0,0 +1,65 @@ +% ------------------------------------------------------------------------------ +% $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} diff --git a/libraries/base/GHC/Word.lhs b/libraries/base/GHC/Word.lhs new file mode 100644 index 0000000000..fe847fc3fd --- /dev/null +++ b/libraries/base/GHC/Word.lhs @@ -0,0 +1,737 @@ +% +% (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} diff --git a/libraries/base/Main.hi-boot b/libraries/base/Main.hi-boot new file mode 100644 index 0000000000..95942f1148 --- /dev/null +++ b/libraries/base/Main.hi-boot @@ -0,0 +1,13 @@ +--------------------------------------------------------------------------- +-- 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. + + diff --git a/libraries/base/Makefile b/libraries/base/Makefile new file mode 100644 index 0000000000..2d87d9b20a --- /dev/null +++ b/libraries/base/Makefile @@ -0,0 +1,74 @@ +# ----------------------------------------------------------------------------- +# $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 diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs new file mode 100644 index 0000000000..8ee9330447 --- /dev/null +++ b/libraries/base/Prelude.hs @@ -0,0 +1,126 @@ +{-# 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 + + diff --git a/libraries/base/System/CPUTime.hsc b/libraries/base/System/CPUTime.hsc new file mode 100644 index 0000000000..b800e8c0b9 --- /dev/null +++ b/libraries/base/System/CPUTime.hsc @@ -0,0 +1,126 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Cmd.hsc b/libraries/base/System/Cmd.hsc new file mode 100644 index 0000000000..2deb48cd00 --- /dev/null +++ b/libraries/base/System/Cmd.hsc @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Environment.hs b/libraries/base/System/Environment.hs new file mode 100644 index 0000000000..d2b0d38e54 --- /dev/null +++ b/libraries/base/System/Environment.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- +-- 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) diff --git a/libraries/base/System/Exit.hs b/libraries/base/System/Exit.hs new file mode 100644 index 0000000000..28597adced --- /dev/null +++ b/libraries/base/System/Exit.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- +-- 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) diff --git a/libraries/base/System/IO.hs b/libraries/base/System/IO.hs new file mode 100644 index 0000000000..752ae9babb --- /dev/null +++ b/libraries/base/System/IO.hs @@ -0,0 +1,192 @@ +{-# 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 diff --git a/libraries/base/System/IO/Directory.hsc b/libraries/base/System/IO/Directory.hsc new file mode 100644 index 0000000000..8a23831740 --- /dev/null +++ b/libraries/base/System/IO/Directory.hsc @@ -0,0 +1,555 @@ +-- ----------------------------------------------------------------------------- +-- $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 = () diff --git a/libraries/base/System/IO/Unsafe.hs b/libraries/base/System/IO/Unsafe.hs new file mode 100644 index 0000000000..ebe4463bfd --- /dev/null +++ b/libraries/base/System/IO/Unsafe.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Info.hs b/libraries/base/System/Info.hs new file mode 100644 index 0000000000..b588aafb56 --- /dev/null +++ b/libraries/base/System/Info.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Locale.hs b/libraries/base/System/Locale.hs new file mode 100644 index 0000000000..cc5a34e8bf --- /dev/null +++ b/libraries/base/System/Locale.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- +-- 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" diff --git a/libraries/base/System/Mem/StableName.hs b/libraries/base/System/Mem/StableName.hs new file mode 100644 index 0000000000..12d2df14a9 --- /dev/null +++ b/libraries/base/System/Mem/StableName.hs @@ -0,0 +1,67 @@ +----------------------------------------------------------------------------- +-- +-- 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") diff --git a/libraries/base/System/Mem/Weak.hs b/libraries/base/System/Mem/Weak.hs new file mode 100644 index 0000000000..09c095dfc8 --- /dev/null +++ b/libraries/base/System/Mem/Weak.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Random.hs b/libraries/base/System/Random.hs new file mode 100644 index 0000000000..aa3ddf6005 --- /dev/null +++ b/libraries/base/System/Random.hs @@ -0,0 +1,279 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/libraries/base/System/Time.hsc b/libraries/base/System/Time.hsc new file mode 100644 index 0000000000..b8d79b4260 --- /dev/null +++ b/libraries/base/System/Time.hsc @@ -0,0 +1,619 @@ +{-# 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 diff --git a/libraries/base/Text/Read.hs b/libraries/base/Text/Read.hs new file mode 100644 index 0000000000..47813eb424 --- /dev/null +++ b/libraries/base/Text/Read.hs @@ -0,0 +1,32 @@ +{-# 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 diff --git a/libraries/base/Text/Show.hs b/libraries/base/Text/Show.hs new file mode 100644 index 0000000000..28294f1c55 --- /dev/null +++ b/libraries/base/Text/Show.hs @@ -0,0 +1,34 @@ +{-# 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 + diff --git a/libraries/base/Text/Show/Functions.hs b/libraries/base/Text/Show/Functions.hs new file mode 100644 index 0000000000..b246c44d30 --- /dev/null +++ b/libraries/base/Text/Show/Functions.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- 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>" diff --git a/libraries/base/cbits/Makefile b/libraries/base/cbits/Makefile new file mode 100644 index 0000000000..d1c450c52f --- /dev/null +++ b/libraries/base/cbits/Makefile @@ -0,0 +1,20 @@ +# $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 diff --git a/libraries/base/cbits/errno.c b/libraries/base/cbits/errno.c new file mode 100644 index 0000000000..0e2d71cbc2 --- /dev/null +++ b/libraries/base/cbits/errno.c @@ -0,0 +1,15 @@ +/* + * (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; +} diff --git a/libraries/base/cbits/inputReady.c b/libraries/base/cbits/inputReady.c new file mode 100644 index 0000000000..4cb9908617 --- /dev/null +++ b/libraries/base/cbits/inputReady.c @@ -0,0 +1,53 @@ +/* + * (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 +} diff --git a/libraries/base/cbits/lockFile.c b/libraries/base/cbits/lockFile.c new file mode 100644 index 0000000000..0ffad7d5ea --- /dev/null +++ b/libraries/base/cbits/lockFile.c @@ -0,0 +1,128 @@ +/* + * (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; +} diff --git a/libraries/base/cbits/system.c b/libraries/base/cbits/system.c new file mode 100644 index 0000000000..289499bf26 --- /dev/null +++ b/libraries/base/cbits/system.c @@ -0,0 +1,87 @@ +/* + * (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 +} diff --git a/libraries/base/cbits/writeError.c b/libraries/base/cbits/writeError.c new file mode 100644 index 0000000000..9f1f1924fe --- /dev/null +++ b/libraries/base/cbits/writeError.c @@ -0,0 +1,51 @@ +/* + * (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); +} diff --git a/libraries/base/doc/libraries.sgml b/libraries/base/doc/libraries.sgml new file mode 100644 index 0000000000..75e2b8e6fc --- /dev/null +++ b/libraries/base/doc/libraries.sgml @@ -0,0 +1,1156 @@ +<!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> + + diff --git a/libraries/base/include/CTypes.h b/libraries/base/include/CTypes.h new file mode 100644 index 0000000000..b2d5c3e40f --- /dev/null +++ b/libraries/base/include/CTypes.h @@ -0,0 +1,335 @@ +/* ----------------------------------------------------------------------------- + * $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__ */ diff --git a/libraries/base/include/Dynamic.h b/libraries/base/include/Dynamic.h new file mode 100644 index 0000000000..eed01bca6d --- /dev/null +++ b/libraries/base/include/Dynamic.h @@ -0,0 +1,27 @@ +/* ----------------------------------------------------------------------------- + * $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)] } diff --git a/libraries/base/include/HsCore.h b/libraries/base/include/HsCore.h new file mode 100644 index 0000000000..1bce35114c --- /dev/null +++ b/libraries/base/include/HsCore.h @@ -0,0 +1,94 @@ +/* ----------------------------------------------------------------------------- + * $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 diff --git a/libraries/base/include/PackedString.h b/libraries/base/include/PackedString.h new file mode 100644 index 0000000000..a0fc8309c3 --- /dev/null +++ b/libraries/base/include/PackedString.h @@ -0,0 +1,14 @@ +/* ----------------------------------------------------------------------------- + * $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 diff --git a/libraries/base/include/ghc_errno.h b/libraries/base/include/ghc_errno.h new file mode 100644 index 0000000000..33b5dce54c --- /dev/null +++ b/libraries/base/include/ghc_errno.h @@ -0,0 +1,15 @@ +/* ----------------------------------------------------------------------------- + * $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 diff --git a/libraries/base/include/lockFile.h b/libraries/base/include/lockFile.h new file mode 100644 index 0000000000..508640f801 --- /dev/null +++ b/libraries/base/include/lockFile.h @@ -0,0 +1,10 @@ +/* + * (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); |