From: dnt Date: Mon, 6 Jan 1997 17:23:57 +0000 (+0000) Subject: [project @ 1997-01-06 17:23:41 by dnt] X-Git-Tag: Approximately_1000_patches_recorded~860 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=b437dc065099e891083dde8549e06d824461e2d2;p=ghc-hetmet.git [project @ 1997-01-06 17:23:41 by dnt] The contents of these files are now spread amongst lib/ghc and lib/required --- diff --git a/ghc/lib/prelude/GHCbase.hs b/ghc/lib/prelude/GHCbase.hs deleted file mode 100644 index 5f48825..0000000 --- a/ghc/lib/prelude/GHCbase.hs +++ /dev/null @@ -1,1727 +0,0 @@ -{- The GHCbase module includes all the basic - (next-level-above-primitives) GHC-specific code; - used to define Prelude.hs, and also other "packagings" - of Glasgow extensions. - - Users should not import it directly. --} -module GHCbase where - -import Array ( array, bounds, assocs ) -import Char (isDigit,isUpper,isSpace,isAlphanum,isAlpha,isOctDigit,isHexDigit) -import Ix -import Ratio -import qualified GHCps ( packString, packCBytes, comparePS, unpackPS ) -import qualified GHCio ( IOError ) -import qualified Monad -import GHCerr - -infixr 0 `seq`, `par`, `fork` - -{- ============================================================= -There's a lot in GHCbase. It's set out as follows: - -* Classes (CCallable, CReturnable, ...) - -* Types and their instances - -* ST, PrimIO, and IO monads - -* Basic arrays - -* Variables - -* Thread waiting - -* Other support functions - -============================================================= -} - -{- ============================================================= -** CLASSES --} - -class CCallable a -class CReturnable a - -{- ============================================================= -** TYPES and their instances --} -data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension -instance CCallable Addr -instance CReturnable Addr - ---------------------------------------------------------------- -data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension -instance CCallable Word -instance CReturnable Word - ---------------------------------------------------------------- -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 = GHCps.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 (GHCps.unpackPS ps) r - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- -data State a = S# (State# a) - -data ForeignObj = ForeignObj ForeignObj# -instance CCallable ForeignObj - -#ifndef __PARALLEL_HASKELL__ -data StablePtr a = StablePtr (StablePtr# a) -instance CCallable (StablePtr a) -instance CReturnable (StablePtr a) -#endif - -eqForeignObj :: ForeignObj -> ForeignObj -> Bool -makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj - -makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) -> - case makeForeignObj# obj finaliser s# of - StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#) - -eqForeignObj mp1 mp2 - = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int) - -instance Eq ForeignObj where - p == q = eqForeignObj p q - p /= q = not (eqForeignObj p q) - -#ifndef __PARALLEL_HASKELL__ - --- Nota Bene: it is important {\em not\/} to inline calls to --- @makeStablePtr#@ since the corresponding macro is very long and we'll --- get terrible code-bloat. - -makeStablePtr :: a -> PrimIO (StablePtr a) -deRefStablePtr :: StablePtr a -> PrimIO a -freeStablePtr :: StablePtr a -> PrimIO () - -performGC :: PrimIO () - -{-# INLINE deRefStablePtr #-} -{-# INLINE freeStablePtr #-} -{-# INLINE performGC #-} - -makeStablePtr f = ST $ \ (S# rw1#) -> - case makeStablePtr# f rw1# of - StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#) - -deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) -> - case deRefStablePtr# sp# rw1# of - StateAndPtr# rw2# a -> (a, S# rw2#) - -freeStablePtr sp = _ccall_ freeStablePointer sp - -performGC = _ccall_GC_ StgPerformGarbageCollection - -#endif /* !__PARALLEL_HASKELL__ */ - ---------------------------------------------------------------- -data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray# -data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray# - -data StateAndPtr# s elt = StateAndPtr# (State# s) elt - -data StateAndChar# s = StateAndChar# (State# s) Char# -data StateAndInt# s = StateAndInt# (State# s) Int# -data StateAndWord# s = StateAndWord# (State# s) Word# -data StateAndFloat# s = StateAndFloat# (State# s) Float# -data StateAndDouble# s = StateAndDouble# (State# s) Double# -data StateAndAddr# s = StateAndAddr# (State# s) Addr# - -#ifndef __PARALLEL_HASKELL__ -data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a) -#endif -data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj# - -data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt) -data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt) -data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray# -data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s) - -data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt) - ---------------------------------------------------------------- -data Lift a = Lift a -{-# GENERATE_SPECS data a :: Lift a #-} - -{- ============================================================= -** ST, PrimIO, and IO monads --} - ---------------------------------------------------------------- ---The state-transformer proper --- By default the monad is strict; too many people got bitten by --- space leaks when it was lazy. - -newtype ST s a = ST (State s -> (a, State s)) - -runST (ST m) - = case m (S# realWorld#) of - (r,_) -> r - -instance Monad (ST s) where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - return x = ST $ \ s@(S# _) -> (x, s) - m >> k = m >>= \ _ -> k - - (ST m) >>= k - = ST $ \ s -> - case (m s) of {(r, new_s) -> - case (k r) of { ST k2 -> - (k2 new_s) }} - -{-# INLINE returnST #-} - --- here for backward compatibility: -returnST :: a -> ST s a -thenST :: ST s a -> (a -> ST s b) -> ST s b -seqST :: ST s a -> ST s b -> ST s b - -returnST = return -thenST = (>>=) -seqST = (>>) - --- not sure whether to 1.3-ize these or what... -{-# INLINE returnStrictlyST #-} -{-# INLINE thenStrictlyST #-} -{-# INLINE seqStrictlyST #-} - -{-# GENERATE_SPECS returnStrictlyST a #-} -returnStrictlyST :: a -> ST s a - -{-# GENERATE_SPECS thenStrictlyST a b #-} -thenStrictlyST :: ST s a -> (a -> ST s b) -> ST s b - -{-# GENERATE_SPECS seqStrictlyST a b #-} -seqStrictlyST :: ST s a -> ST s b -> ST s b - -returnStrictlyST a = ST $ \ s@(S# _) -> (a, s) - -thenStrictlyST (ST m) k = ST $ \ s -> -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state - case (m s) of { (r, new_s) -> - case (k r) of { ST k2 -> - (k2 new_s) }} - -seqStrictlyST (ST m) (ST k) = ST $ \ s -> -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state - case (m s) of { (_, new_s) -> - (k new_s) } - --- BUILT-IN: runST (see Builtin.hs) - -unsafeInterleaveST :: ST s a -> ST s a -- ToDo: put in state-interface.tex -unsafeInterleaveST (ST m) = ST $ \ s -> - let - (r, new_s) = m s - in - (r, s) - -fixST :: (a -> ST s a) -> ST s a -fixST k = ST $ \ s -> - let (ST k_r) = k r - ans = k_r s - (r,new_s) = ans - in - ans - --- more backward compatibility stuff: -listST :: [ST s a] -> ST s [a] -mapST :: (a -> ST s b) -> [a] -> ST s [b] -mapAndUnzipST :: (a -> ST s (b,c)) -> [a] -> ST s ([b],[c]) - -listST = accumulate -mapST = mapM -mapAndUnzipST = Monad.mapAndUnzipL - -forkST :: ST s a -> ST s a - -#ifndef __CONCURRENT_HASKELL__ -forkST x = x -#else - -forkST (ST action) = ST $ \ s -> - let - (r, new_s) = action s - in - new_s `fork__` (r, s) - where - fork__ x y = case (fork# x) of { 0# -> parError; _ -> y } - -#endif {- concurrent -} - ----------------------------------------------------------------------------- -type PrimIO a = ST RealWorld a - -fixPrimIO :: (a -> PrimIO a) -> PrimIO a -fixPrimIO = fixST - -stToIO :: ST RealWorld a -> IO a -primIOToIO :: PrimIO a -> IO a -ioToST :: IO a -> ST RealWorld a -ioToPrimIO :: IO a -> PrimIO a - -primIOToIO = stToIO -- for backwards compatibility -ioToPrimIO = ioToST - -stToIO (ST m) = IO $ ST $ \ s -> - case (m s) of { (r, new_s) -> - (Right r, new_s) } - -ioToST (IO (ST io)) = ST $ \ s -> - case (io s) of { (r, new_s) -> - case r of - Right a -> (a, new_s) - Left e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n") - } - -{-# GENERATE_SPECS unsafePerformPrimIO a #-} -unsafePerformPrimIO :: PrimIO a -> a -unsafeInterleavePrimIO :: PrimIO a -> PrimIO a -forkPrimIO :: PrimIO a -> PrimIO a - -unsafePerformPrimIO = runST -unsafeInterleavePrimIO = unsafeInterleaveST -forkPrimIO = forkST - --- the following functions are now there for backward compatibility mostly: - -{-# GENERATE_SPECS returnPrimIO a #-} -returnPrimIO :: a -> PrimIO a - -{-# GENERATE_SPECS thenPrimIO b #-} -thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b - -{-# GENERATE_SPECS seqPrimIO b #-} -seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b - -listPrimIO :: [PrimIO a] -> PrimIO [a] -mapPrimIO :: (a -> PrimIO b) -> [a] -> PrimIO [b] -mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c]) - -{-# INLINE returnPrimIO #-} -{-# INLINE thenPrimIO #-} -{-# INLINE seqPrimIO #-} - -returnPrimIO = return -thenPrimIO = (>>=) -seqPrimIO = (>>) -listPrimIO = accumulate -mapPrimIO = mapM -mapAndUnzipPrimIO = Monad.mapAndUnzipL - ---------------------------------------------------------- -newtype IO a = IO (PrimIO (Either GHCio.IOError a)) - -instance Functor IO where - map f x = x >>= (return . f) - -instance Monad IO where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return x = IO $ ST $ \ s@(S# _) -> (Right x, s) - - (IO (ST m)) >>= k - = IO $ ST $ \ s -> - let (r, new_s) = m s in - case r of - Left err -> (Left err, new_s) - Right x -> case (k x) of { IO (ST k2) -> - k2 new_s } - -instance Show (IO a) where - showsPrec p f = showString "<>" - showList = showList__ (showsPrec 0) - -fixIO :: (a -> IO a) -> IO a - -- not required but worth having around - -fixIO k = IO $ ST $ \ s -> - let - (IO (ST k_loop)) = k loop - result = k_loop s - (Right loop, _) = result - in - result - -{- ============================================================= -** BASIC ARRAY (and ByteArray) SUPPORT --} - -type IPr = (Int, Int) - -data Ix ix => Array ix elt = Array (ix,ix) (Array# elt) -data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray# - -instance CCallable (ByteArray ix) - -instance (Ix a, Eq b) => Eq (Array a b) where - a == a' = assocs a == assocs a' - a /= a' = assocs a /= assocs a' - -instance (Ix a, Ord b) => Ord (Array a b) where - compare a b = compare (assocs a) (assocs b) - -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) ) - showList = showList__ (showsPrec 0) - -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 ]) - readList = readList__ (readsPrec 0) - ------------------------------------------------------------------ --- Mutable arrays -{- -Idle ADR question: What's the tradeoff here between flattening these -datatypes into @MutableArray 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. --} - -data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) -data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) - -instance CCallable (MutableByteArray s ix) - -newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) -newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray - :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) - -{-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), - (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt) - #-} -{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-} - -newArray ixs@(ix_start, ix_end) init = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else (index ixs ix_end) + 1) of { I# x -> x } - -- size is one bigger than index of last elem - in - case (newArray# n# init s#) of { StateAndMutableArray# s2# arr# -> - (MutableArray ixs arr#, S# s2#)} - -newCharArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray ixs barr#, S# s2#)} - -newIntArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray ixs barr#, S# s2#)} - -newAddrArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray ixs barr#, S# s2#)} - -newFloatArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray ixs barr#, S# s2#)} - -newDoubleArray ixs@(ix_start, ix_end) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray ixs barr#, S# s2#)} - -boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) -boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) - -{-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-} -{-# SPECIALIZE boundsOfByteArray :: MutableByteArray s Int -> IPr #-} - -boundsOfArray (MutableArray ixs _) = ixs -boundsOfByteArray (MutableByteArray ixs _) = ixs - -readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt - -readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char -readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int -readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr -readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float -readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double - -{-# SPECIALIZE readArray :: MutableArray s Int elt -> Int -> ST s elt, - MutableArray s IPr elt -> IPr -> ST s elt - #-} -{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-} -{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-} -{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-} ---NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-} -{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-} - -readArray (MutableArray ixs arr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readArray# arr# n# s# of { StateAndPtr# s2# r -> - (r, S# s2#)}} - -readCharArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readCharArray# barr# n# s# of { StateAndChar# s2# r# -> - (C# r#, S# s2#)}} - -readIntArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readIntArray# barr# n# s# of { StateAndInt# s2# r# -> - (I# r#, S# s2#)}} - -readAddrArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readAddrArray# barr# n# s# of { StateAndAddr# s2# r# -> - (A# r#, S# s2#)}} - -readFloatArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readFloatArray# barr# n# s# of { StateAndFloat# s2# r# -> - (F# r#, S# s2#)}} - -readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case readDoubleArray# barr# n# s# of { StateAndDouble# s2# r# -> - (D# r#, S# s2#)}} - ---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 -indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr -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 #-} -{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-} ---NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-} -{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-} - -indexCharArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexCharArray# barr# n# of { r# -> - (C# r#)}} - -indexIntArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexIntArray# barr# n# of { r# -> - (I# r#)}} - -indexAddrArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexAddrArray# barr# n# of { r# -> - (A# r#)}} - -indexFloatArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexFloatArray# barr# n# of { r# -> - (F# r#)}} - -indexDoubleArray (ByteArray ixs barr#) n - = case (index ixs n) of { I# n# -> - case indexDoubleArray# barr# n# of { r# -> - (D# r#)}} - ---Indexing off @Addrs@ is similar, and therefore given here. -indexCharOffAddr :: Addr -> Int -> Char -indexIntOffAddr :: Addr -> Int -> Int -indexAddrOffAddr :: Addr -> Int -> Addr -indexFloatOffAddr :: Addr -> Int -> Float -indexDoubleOffAddr :: Addr -> Int -> Double - -indexCharOffAddr (A# addr#) n - = case n of { I# n# -> - case indexCharOffAddr# addr# n# of { r# -> - (C# r#)}} - -indexIntOffAddr (A# addr#) n - = case n of { I# n# -> - case indexIntOffAddr# addr# n# of { r# -> - (I# r#)}} - -indexAddrOffAddr (A# addr#) n - = case n of { I# n# -> - case indexAddrOffAddr# addr# n# of { r# -> - (A# r#)}} - -indexFloatOffAddr (A# addr#) n - = case n of { I# n# -> - case indexFloatOffAddr# addr# n# of { r# -> - (F# r#)}} - -indexDoubleOffAddr (A# addr#) n - = case n of { I# n# -> - case indexDoubleOffAddr# addr# n# of { r# -> - (D# r#)}} - -writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () -writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () -writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () -writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> ST s () -writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () -writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () - -{-# SPECIALIZE writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (), - MutableArray s IPr elt -> IPr -> elt -> ST s () - #-} -{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} -{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} -{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-} ---NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} -{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} - -writeArray (MutableArray ixs arr#) n ele = ST $ \ (S# s#) -> - case index ixs n of { I# n# -> - case writeArray# arr# n# ele s# of { s2# -> - ((), S# s2#)}} - -writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case writeCharArray# barr# n# ele s# of { s2# -> - ((), S# s2#)}} - -writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case writeIntArray# barr# n# ele s# of { s2# -> - ((), S# s2#)}} - -writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case writeAddrArray# barr# n# ele s# of { s2# -> - ((), S# s2#)}} - -writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case writeFloatArray# barr# n# ele s# of { s2# -> - ((), S# s2#)}} - -writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ (S# s#) -> - case (index ixs n) of { I# n# -> - case writeDoubleArray# barr# n# ele s# of { s2# -> - ((), S# s2#)}} - -freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeFloatArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) -freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt), - MutableArray s IPr elt -> ST s (Array IPr elt) - #-} -{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} - -freezeArray (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else (index ixs ix_end) + 1) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndArray# s2# frozen# -> - (Array ixs frozen#, S# s2#)} - where - freeze :: MutableArray# s ele -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndArray# s ele - - freeze arr# n# s# - = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableArray# s3# newarr2# -> - unsafeFreezeArray# newarr2# s3# - }} - where - init = error "freezeArray: element not copied" - - copy :: Int# -> Int# - -> MutableArray# s ele -> MutableArray# s ele - -> State# s - -> StateAndMutableArray# s ele - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableArray# s# to# - | True - = case readArray# from# cur# s# of { StateAndPtr# s1# ele -> - case writeArray# to# cur# ele s1# of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeCharArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndByteArray# s - - freeze arr# n# s# - = case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> StateAndMutableByteArray# s - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableByteArray# s# to# - | True - = case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele -> - case (writeCharArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeIntArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndByteArray# s - - freeze arr# n# s# - = case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> StateAndMutableByteArray# s - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableByteArray# s# to# - | True - = case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele -> - case (writeIntArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeAddrArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndByteArray# s - - freeze arr# n# s# - = case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> StateAndMutableByteArray# s - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableByteArray# s# to# - | True - = case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele -> - case (writeAddrArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeFloatArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndByteArray# s - - freeze arr# n# s# - = case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> StateAndMutableByteArray# s - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableByteArray# s# to# - | True - = case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele -> - case (writeFloatArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -freezeDoubleArray (MutableByteArray ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else ((index ixs ix_end) + 1)) of { I# x -> x } - in - case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - where - freeze :: MutableByteArray# s -- the thing - -> Int# -- size of thing to be frozen - -> State# s -- the Universe and everything - -> StateAndByteArray# s - - freeze arr# n# s# - = case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> - case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> - unsafeFreezeByteArray# newarr2# s3# - }} - where - copy :: Int# -> Int# - -> MutableByteArray# s -> MutableByteArray# s - -> State# s - -> StateAndMutableByteArray# s - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableByteArray# s# to# - | True - = case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele -> - case (writeDoubleArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} - -unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) -unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) - #-} - -unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ (S# s#) -> - case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# -> - (Array ixs frozen#, S# s2#) } - -unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) -> - case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } - - ---This takes a immutable array, and copies it into a mutable array, in a ---hurry. - -{-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt), - Array IPr elt -> ST s (MutableArray s IPr elt) - #-} - -thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (S# s#) -> - let n# = case (if null (range ixs) - then 0 - else (index ixs ix_end) + 1) of { I# x -> x } - in - case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# -> - (MutableArray ixs thawed#, S# s2#)} - where - thaw :: Array# ele -- the thing - -> Int# -- size of thing to be thawed - -> State# s -- the Universe and everything - -> StateAndMutableArray# s ele - - thaw arr# n# s# - = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# -> - copy 0# n# arr# newarr1# s2# } - where - init = error "thawArray: element not copied" - - copy :: Int# -> Int# - -> Array# ele - -> MutableArray# s ele - -> State# s - -> StateAndMutableArray# s ele - - copy cur# end# from# to# s# - | cur# ==# end# - = StateAndMutableArray# s# to# - | True - = case indexArray# from# cur# of { Lift ele -> - case writeArray# to# cur# ele s# of { s1# -> - copy (cur# +# 1#) end# from# to# s1# - }} - -sameMutableArray :: MutableArray s ix elt -> MutableArray s ix elt -> Bool -sameMutableByteArray :: MutableByteArray s ix -> MutableByteArray s ix -> Bool - -sameMutableArray (MutableArray _ arr1#) (MutableArray _ arr2#) - = sameMutableArray# arr1# arr2# - -sameMutableByteArray (MutableByteArray _ arr1#) (MutableByteArray _ arr2#) - = sameMutableByteArray# arr1# arr2# - -{- ============================================================= -** VARIABLES, including MVars and IVars --} - ---************************************************************************ --- Variables - -type MutableVar s a = MutableArray s Int a - -newVar :: a -> ST s (MutableVar s a) -readVar :: MutableVar s a -> ST s a -writeVar :: MutableVar s a -> a -> ST s () -sameVar :: MutableVar s a -> MutableVar s a -> Bool - -newVar init = ST $ \ (S# s#) -> - case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# -> - (MutableArray vAR_IXS arr#, S# s2#) } - where - vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n" - -readVar (MutableArray _ var#) = ST $ \ (S# s#) -> - case readArray# var# 0# s# of { StateAndPtr# s2# r -> - (r, S# s2#) } - -writeVar (MutableArray _ var#) val = ST $ \ (S# s#) -> - case writeArray# var# 0# val s# of { s2# -> - ((), S# s2#) } - -sameVar (MutableArray _ var1#) (MutableArray _ var2#) - = sameMutableArray# var1# var2# - ---%************************************************************************ ---%* * ---\subsection[PreludeGlaST-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. --} - -data MVar a = MVar (SynchVar# RealWorld a) - -newEmptyMVar :: IO (MVar a) - -newEmptyMVar = IO $ ST $ \ (S# s#) -> - case newSynchVar# s# of - StateAndSynchVar# s2# svar# -> (Right (MVar svar#), S# s2#) - -takeMVar :: MVar a -> IO a - -takeMVar (MVar mvar#) = IO $ ST $ \ (S# s#) -> - case takeMVar# mvar# s# of - StateAndPtr# s2# r -> (Right r, S# s2#) - -putMVar :: MVar a -> a -> IO () - -putMVar (MVar mvar#) x = IO $ ST $ \ (S# s#) -> - case putMVar# mvar# x s# of - s2# -> (Right (), S# s2#) - -newMVar :: a -> IO (MVar a) - -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - -readMVar :: MVar a -> IO a - -readMVar mvar = - takeMVar mvar >>= \ value -> - putMVar mvar value >> - return value - -swapMVar :: MVar a -> a -> IO a - -swapMVar mvar new = - takeMVar mvar >>= \ old -> - putMVar mvar new >> - return old - ---%************************************************************************ ---%* * ---\subsection[PreludeGlaST-ivars]{I-Structures} ---%* * ---%************************************************************************ -{- -I-Vars are write-once variables. They start out empty, and any threads that -attempt to read them will block until they are filled. Once they are written, -any blocked threads are freed, and additional reads are permitted. Attempting -to write a value to a full I-Var results in a runtime error. --} -data IVar a = IVar (SynchVar# RealWorld a) - -newIVar :: IO (IVar a) - -newIVar = IO $ ST $ \ (S# s#) -> - case newSynchVar# s# of - StateAndSynchVar# s2# svar# -> (Right (IVar svar#), S# s2#) - -readIVar :: IVar a -> IO a - -readIVar (IVar ivar#) = IO $ ST $ \ (S# s#) -> - case readIVar# ivar# s# of - StateAndPtr# s2# r -> (Right r, S# s2#) - -writeIVar :: IVar a -> a -> IO () - -writeIVar (IVar ivar#) x = IO $ ST $ \ (S# s#) -> - case writeIVar# ivar# x s# of - s2# -> (Right (), S# s2#) - -{- ============================================================= -** 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.) - -@threadWait@ delays rescheduling of a thread until input on the -specified file descriptor is available for reading (just like select). --} - -threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () - -threadDelay (I# x#) = IO $ ST $ \ (S# s#) -> - case delay# x# s# of - s2# -> (Right (), S# s2#) - -threadWaitRead (I# x#) = IO $ ST $ \ (S# s#) -> - case waitRead# x# s# of - s2# -> (Right (), S# s2#) - -threadWaitWrite (I# x#) = IO $ ST $ \ (S# s#) -> - case waitWrite# x# s# of - s2# -> (Right (), S# s2#) - -{- ============================================================= -** OTHER SUPPORT FUNCTIONS - - 3 flavors, basically: string support, error/trace-ish, and read/show-ish. --} -seq, par, fork :: Eval a => a -> b -> b - -{-# INLINE seq #-} -{-# INLINE par #-} -{-# INLINE fork #-} - -#ifdef __CONCURRENT_HASKELL__ -seq x y = case (seq# x) of { 0# -> parError; _ -> y } -par x y = case (par# x) of { 0# -> parError; _ -> y } -fork x y = case (fork# x) of { 0# -> parError; _ -> y } -#else -seq x y = y -par x y = y -fork x y = y -#endif - --- string-support functions: ---------------------------------------------------------------- - --------------------------------------------------------------------------- - -packStringForC__ :: [Char] -> ByteArray# -- calls injected by compiler -unpackPS__ :: Addr# -> [Char] -- calls injected by compiler -unpackPS2__ :: Addr# -> Int# -> [Char] -- calls injected by compiler -unpackAppendPS__ :: Addr# -> [Char] -> [Char] -- ditto? -unpackFoldrPS__ :: Addr# -> (Char -> a -> a) -> a -> a -- ditto? - -packStringForC__ str = case (GHCps.packString str) of { PS bytes _ _ -> bytes} - -unpackPS__ addr -- calls injected by compiler - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | True = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackAppendPS__ addr rest - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = rest - | True = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackFoldrPS__ addr f z - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = z - | True = C# ch `f` unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackPS2__ addr len -- calls injected by compiler - -- this one is for literal strings with NULs in them; rare. - = GHCps.unpackPS (GHCps.packCBytes (I# len) (A# addr)) - ---------------------------------------------------------------- --- injected literals: ---------------------------------------------------------------- -integer_0, integer_1, integer_2, integer_m1 :: Integer - -integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1 - ---------------------------------------------------------------- --- error/trace-ish functions: ---------------------------------------------------------------- - -errorIO :: PrimIO () -> a - -errorIO (ST io) - = case (errorIO# io) of - _ -> bottom - where - bottom = bottom -- Never evaluated - -error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a - -error__ msg_hdr s -#ifdef __PARALLEL_HASKELL__ - = errorIO (msg_hdr sTDERR{-msg hdr-} >> - _ccall_ fflush sTDERR >> - fputs sTDERR s >> - _ccall_ fflush sTDERR >> - _ccall_ stg_exit (1::Int) - ) -#else - = errorIO (msg_hdr sTDERR{-msg hdr-} >> - _ccall_ fflush sTDERR >> - fputs sTDERR s >> - _ccall_ fflush sTDERR >> - _ccall_ getErrorHandler >>= \ errorHandler -> - if errorHandler == (-1::Int) then - _ccall_ stg_exit (1::Int) - else - _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler - >>= \ osptr -> - _ccall_ decrementErrorCount >>= \ () -> - deRefStablePtr osptr >>= \ oact -> - oact - ) -#endif {- !parallel -} - where - sTDERR = (``stderr'' :: Addr) - ---------------- - -fputs :: Addr{-FILE*-} -> String -> PrimIO Bool - -fputs stream [] = return True - -fputs stream (c : cs) - = _ccall_ stg_putc c stream >> -- stg_putc expands to putc - fputs stream cs -- (just does some casting stream) - ---------------------------------------------------------------- --- ******** defn of `_trace' using Glasgow IO ******* - -{-# GENERATE_SPECS _trace a #-} - -trace :: String -> a -> a - -trace string expr - = unsafePerformPrimIO ( - ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ()) >> - fputs sTDERR string >> - ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >> - returnPrimIO expr ) - where - sTDERR = (``stderr'' :: Addr) - ---------------------------------------------------------------- --- read/show-ish functions: ---------------------------------------------------------------- -{-# GENERATE_SPECS readList__ a #-} -readList__ :: ReadS a -> ReadS [a] - -readList__ readx - = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) - where readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- readx s, - (xs,u) <- readl2 t] - readl2 s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, - (x,u) <- readx t, - (xs,v) <- readl2 u] - -{-# GENERATE_SPECS showList__ a #-} -showList__ :: (a -> ShowS) -> [a] -> ShowS - -showList__ showx [] = showString "[]" -showList__ showx (x:xs) = showChar '[' . showx x . showl xs - where - showl [] = showChar ']' - showl (x:xs) = showString ", " . showx x . showl xs - -showSpace :: ShowS -showSpace = {-showChar ' '-} \ xs -> ' ' : xs - --- ****************************************************************** - --- 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 - -lex :: ReadS String -lex "" = [("","")] -lex (c:s) | isSpace c = lex (dropWhile isSpace s) -lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, - ch /= "'" ] -lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] - where - lexString ('"':s) = [("\"",s)] - lexString s = [(ch++str, u) - | (ch,t) <- lexStrItem s, - (str,u) <- lexString t ] - - lexStrItem ('\\':'&':s) = [("\\&",s)] - lexStrItem ('\\':c:s) | isSpace c - = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] - lexStrItem s = lexLitChar s - -lex (c:s) | isSingle c = [([c],s)] - | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]] - | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] - | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], - (fe,t) <- lexFracExp s ] - | otherwise = [] -- bad character - where - isSingle c = c `elem` ",;()[]{}_`" - isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" - isIdChar c = isAlphanum c || c `elem` "_'" - - lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s, - (e,u) <- lexExp t] - lexFracExp s = [("",s)] - - lexExp (e:s) | e `elem` "eE" - = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", - (ds,u) <- lexDigits t] ++ - [(e:ds,t) | (ds,t) <- lexDigits s] - lexExp s = [("",s)] - -lexDigits :: ReadS String -lexDigits = nonnull isDigit - -nonnull :: (Char -> Bool) -> ReadS String -nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] - -lexLitChar :: ReadS String -lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] - where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] - lexEsc s@(d:_) | isDigit d = lexDigits s - lexEsc _ = [] -lexLitChar (c:s) = [([c],s)] -lexLitChar "" = [] - - -match :: (Eq a) => [a] -> [a] -> ([a],[a]) -match (x:xs) (y:ys) | x == y = match xs ys -match xs ys = (xs,ys) - -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"] - -readLitChar :: ReadS Char - -readLitChar ('\\':s) = readEsc s - where - readEsc ('a':s) = [('\a',s)] - readEsc ('b':s) = [('\b',s)] - readEsc ('f':s) = [('\f',s)] - readEsc ('n':s) = [('\n',s)] - readEsc ('r':s) = [('\r',s)] - readEsc ('t':s) = [('\t',s)] - readEsc ('v':s) = [('\v',s)] - readEsc ('\\':s) = [('\\',s)] - readEsc ('"':s) = [('"',s)] - readEsc ('\'':s) = [('\'',s)] - readEsc ('^':c:s) | c >= '@' && c <= '_' - = [(chr (ord c - ord '@'), s)] - readEsc s@(d:_) | isDigit d - = [(chr n, t) | (n,t) <- readDec s] - readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] - readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] - 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:_) -> [pr] - [] -> [] - readEsc _ = [] -readLitChar (c:s) = [(c,s)] - -showLitChar :: Char -> ShowS -showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) -showLitChar '\DEL' = showString "\\DEL" -showLitChar '\\' = showString "\\\\" -showLitChar c | c >= ' ' = showChar c -showLitChar '\a' = showString "\\a" -showLitChar '\b' = showString "\\b" -showLitChar '\f' = showString "\\f" -showLitChar '\n' = showString "\\n" -showLitChar '\r' = showString "\\r" -showLitChar '\t' = showString "\\t" -showLitChar '\v' = showString "\\v" -showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") -showLitChar c = showString ('\\' : asciiTab!!ord c) - -protectEsc p f = f . cont - where cont s@(c:_) | p c = "\\&" ++ s - cont s = s - --- ****************************************************************** - -{-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-} -readDec :: (Integral a) => ReadS a -readDec = readInt 10 isDigit (\d -> ord d - ord_0) - -{-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-} -readOct :: (Integral a) => ReadS a -readOct = readInt 8 isOctDigit (\d -> ord d - ord_0) - -{-# GENERATE_SPECS readHex a{Int#,Int,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) - -{-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-} -readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a -readInt radix isDig digToInt s = - [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r) - | (ds,r) <- nonnull isDig s ] - -showInt n r - = case quotRem n 10 of { (n', d) -> - case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary - let - r' = C# c# : r - in - if n' == 0 then r' else showInt n' r' - }} - --- ****************************************************************** - -{-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-} -readSigned :: (Real a) => ReadS a -> ReadS a -readSigned readPos = readParen False read' - where read' r = read'' r ++ - [(-x,t) | ("-",s) <- lex r, - (x,t) <- read'' s] - read'' r = [(n,s) | (str,s) <- lex r, - (n,"") <- readPos str] - - -{-# SPECIALIZE showSigned :: (Int -> ShowS) -> Int -> Int -> ShowS = showSigned_Int, - (Integer -> ShowS) -> Int -> Integer -> ShowS = showSigned_Integer #-} -{-# GENERATE_SPECS showSigned a{Double#,Double} #-} -showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS -showSigned showPos p x = if x < 0 then showParen (p > 6) - (showChar '-' . showPos (-x)) - else showPos x - -showSigned_Int :: (Int -> ShowS) -> Int -> Int -> ShowS -showSigned_Int _ p n r - = -- from HBC version; support code follows - if n < 0 && p > 6 then '(':itos n++(')':r) else itos n ++ r - -showSigned_Integer :: (Integer -> ShowS) -> Int -> Integer -> ShowS -showSigned_Integer _ p n r - = -- from HBC version; support code follows - if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r - --- ****************************************************************** - -itos# :: Int# -> String -itos# n = - if n `ltInt#` 0# then - if negateInt# n `ltInt#` 0# then - -- n is minInt, a difficult number - itos# (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) [] - else - '-':itos' (negateInt# n) [] - else - itos' n [] - where - itos' :: Int# -> String -> String - itos' n cs = - if n `ltInt#` 10# then - C# (chr# (n `plusInt#` ord# '0'#)) : cs - else - itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# `plusInt#` ord# '0'#)) : cs) - -itos :: Int -> String -itos (I# n) = itos# n - -jtos :: Integer -> String -jtos n - = if n < 0 then - '-' : jtos' (-n) [] - else - jtos' n [] - -jtos' :: Integer -> String -> String -jtos' n cs - = if n < 10 then - chr (fromInteger (n + ord_0)) : cs - else - jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs) - -chr = (toEnum :: Int -> Char) -ord = (fromEnum :: Char -> Int) - -ord_0 :: Num a => a -ord_0 = fromInt (ord '0') - --- ****************************************************************** - --- The functions readFloat and showFloat below use rational arithmetic --- to insure 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. - -{-# GENERATE_SPECS readFloat a{Double#,Double} #-} -readFloat :: (RealFloat a) => ReadS a -readFloat r = [(fromRational x, t) | (x, t) <- readRational r] - -readRational :: ReadS Rational -- NB: doesn't handle leading "-" - -readRational r - = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r, - (k,t) <- readExp s] - where readFix r = [(read (ds++ds'), length ds', t) - | (ds,'.':s) <- lexDigits r, - (ds',t) <- lexDigits s ] - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = [(0,s)] - - readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] - readExp' ('+':s) = readDec s - readExp' s = readDec 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 [x | (x,t) <- readRational s, ("","") <- lex t] of - [x] -> x - [] -> error ("readRational__: no parse:" ++ top_s) - _ -> error ("readRational__: ambiguous parse:" ++ top_s) - --- The number of decimal digits m below is chosen to guarantee --- read (show x) == x. See --- Matula, D. W. A formalization of floating-point numeric base --- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), --- 681-692. - -zeros = repeat '0' - -{-# GENERATE_SPECS showFloat a{Double#,Double} #-} -showFloat:: (RealFloat a) => a -> ShowS -showFloat x = - if x == 0 then showString ("0." ++ take (m-1) zeros) - else if e >= m-1 || e < 0 then showSci else showFix - where - showFix = showString whole . showChar '.' . showString frac - where (whole,frac) = splitAt (e+1) (show sig) - showSci = showChar d . showChar '.' . showString frac - . showChar 'e' . shows e - where (d:frac) = show sig - (m, sig, e) = if b == 10 then (w, s, n+w-1) - else (m', sig', e' ) - m' = ceiling - ((fromInt w * log (fromInteger b)) / log 10 :: Double) - + 1 - (sig', e') = if sig1 >= 10^m' then (round (t/10), e1+1) - else if sig1 < 10^(m'-1) then (round (t*10), e1-1) - else (sig1, e1 ) - sig1 = round t - t = s%1 * (b%1)^^n * 10^^(m'-e1-1) - e1 = floor (logBase 10 x) - (s, n) = decodeFloat x - b = floatRadix x - w = floatDigits x - ---------------------------------------------------------- --- definitions of the boxed PrimOps; these will be --- used in the case of partial applications, etc. - -plusInt (I# x) (I# y) = I# (plusInt# x y) -minusInt(I# x) (I# y) = I# (minusInt# x y) -timesInt(I# x) (I# y) = I# (timesInt# x y) -quotInt (I# x) (I# y) = I# (quotInt# x y) -remInt (I# x) (I# y) = I# (remInt# x y) -negateInt (I# x) = I# (negateInt# x) -gtInt (I# x) (I# y) = gtInt# x y -geInt (I# x) (I# y) = geInt# x y -eqInt (I# x) (I# y) = eqInt# x y -neInt (I# x) (I# y) = neInt# x y -ltInt (I# x) (I# y) = ltInt# x y -leInt (I# x) (I# y) = leInt# x y - --- definitions of the boxed PrimOps; these will be --- used in the case of partial applications, etc. - -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 (F# x) = F# (negateFloat# x) - -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 (F# x) = I# (float2Int# x) -int2Float (I# x) = F# (int2Float# x) - -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 (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 (D# x) (D# y) = D# (plusDouble# x y) -minusDouble (D# x) (D# y) = D# (minusDouble# x y) -timesDouble (D# x) (D# y) = D# (timesDouble# x y) -divideDouble (D# x) (D# y) = D# (divideDouble# x y) -negateDouble (D# x) = D# (negateDouble# x) - -gtDouble (D# x) (D# y) = gtDouble# x y -geDouble (D# x) (D# y) = geDouble# x y -eqDouble (D# x) (D# y) = eqDouble# x y -neDouble (D# x) (D# y) = neDouble# x y -ltDouble (D# x) (D# y) = ltDouble# x y -leDouble (D# x) (D# y) = leDouble# x y - -double2Int (D# x) = I# (double2Int# x) -int2Double (I# x) = D# (int2Double# x) -double2Float (D# x) = F# (double2Float# x) -float2Double (F# x) = D# (float2Double# x) - -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 (D# x) (D# y) = D# (powerDouble# x y) - ---------------------------------------------------------- -{- -[In response to a request by simonpj, 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. - -How's this? - -Joe --} - -{-# GENERATE_SPECS fromRational__ a{Double#,Double} #-} -fromRational__ :: (RealFloat a) => Rational -> a -fromRational__ 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)) - -------------------------------------------------------------------------- --- from/by Lennart, 94/09/26 - --- Convert a Rational to a string that looks like a floating point number, --- but without converting to any floating type (because of the possible overflow). -showRational :: Int -> Rational -> String -showRational n r = - if r == 0 then - "0.0" - else - let (r', e) = normalize r - in prR n r' e - -startExpExp = 4 :: Int - --- make sure 1 <= r < 10 -normalize :: Rational -> (Rational, Int) -normalize r = if r < 1 then - case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1) - else - norm startExpExp r 0 - where norm :: Int -> Rational -> Int -> (Rational, Int) - -- Invariant: r*10^e == original r - norm 0 r e = (r, e) - norm ee r e = - let n = 10^ee - tn = 10^n - in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e - -drop0 "" = "" -drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs)) - -prR :: Int -> Rational -> Int -> String -prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment -prR n r e | r >= 10 = prR n (r/10) (e+1) -prR n r e0 = - let s = show ((round (r * 10^n))::Integer) - e = e0+1 - in if e > 0 && e < 8 then - take e s ++ "." ++ drop0 (drop e s) - else if e <= 0 && e > -3 then - "0." ++ take (-e) (repeat '0') ++ drop0 s - else - head s : "."++ drop0 (tail s) ++ "e" ++ show e0 diff --git a/ghc/lib/prelude/GHCerr.hs b/ghc/lib/prelude/GHCerr.hs deleted file mode 100644 index 202fee2..0000000 --- a/ghc/lib/prelude/GHCerr.hs +++ /dev/null @@ -1,66 +0,0 @@ -{- The GHCerr 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., GHCbase), because the magical wired-in type will get - confused with what the typechecker figures out. --} -module GHCerr where - -import GHCbase (error__) - ---------------------------------------------------------------- --- HACK: Magic unfoldings not implemented for unboxed lists --- Need to define a "build" to avoid undefined symbol --- in this module to avoid .hi proliferation. - -build = error "GHCbase.build" -augment = error "GHCbase.augment" ---{-# GENERATE_SPECS build a #-} ---build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] ---build g = g (:) [] - - ---------------------------------------------------------------- -cannon_fodder_to_avoid_empty__versions__ = (1::Int) - --- Used for compiler-generated error message; --- encoding saves bytes of string junk. - -absentErr, parError :: a -irrefutPatError - , noDefaultMethodError - , noExplicitMethodError - , nonExhaustiveGuardsError - , patError - , recConError - , recUpdError :: String -> a - -absentErr = error "Oops! The program has entered an `absent' argument!\n" -parError = error "Oops! Entered GHCbase.parError (a GHC bug -- please report it!)\n" - -noDefaultMethodError s = error ("noDefaultMethodError:"++s) -noExplicitMethodError s = error ("noExplicitMethodError:"++s) - -irrefutPatError s = patError__ (untangle s "irrefutable pattern") -nonExhaustiveGuardsError s = patError__ (untangle s "non-exhaustive guards") -patError s = patError__ (untangle s "pattern-matching") - -patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x) - -recConError s = error (untangle s "record constructor") -recUpdError s = error (untangle s "record update") - -untangle coded in_str - = "In " ++ in_str - ++ (if null msg then "" else (": " ++ msg)) - ++ "; at " ++ file - ++ ", line " ++ line - ++ "\n" - where - (file,line,msg) - = case (span not_bar coded) of { (f, (_:rest)) -> - case (span not_bar rest) of { (l, (_:m)) -> - (f,l,m) }} - not_bar c = c /= '|' diff --git a/ghc/lib/prelude/GHCio.hs b/ghc/lib/prelude/GHCio.hs deleted file mode 100644 index a902ec0..0000000 --- a/ghc/lib/prelude/GHCio.hs +++ /dev/null @@ -1,950 +0,0 @@ -{- -% -% (c) The AQUA Project, Glasgow University, 1994-1996 -% - -This module defines Haskell {\em handles} and the basic operations -which are supported for them. --} - -#include "error.h" - -module GHCio where - -import GHCbase -import qualified GHCps ( unpackPS, packCString ) -import Ix (Ix(..)) - ---------------------------------- -infixr 1 `stThen` - --- a useful little number for doing _ccall_s in IO-land: - -stThen :: PrimIO a -> (a -> IO b) -> IO b -{-# INLINE stThen #-} - -stThen (ST m) k = IO $ ST $ \ s -> - case (m s) of { (m_res, new_s) -> - case (k m_res) of { (IO (ST k_m_res)) -> - k_m_res new_s }} - ---------------------------------- --- this one didn't make it into the 1.3 defn - --- The construct $try comp$ exposes errors which occur within a --- computation, and which are not fully handled. It always succeeds. - -tryIO :: IO a -> IO (Either IOError a) -tryIO p = catch (p >>= (return . Right)) (return . Left) - ---------------------------------- - -data Handle__ - = ErrorHandle IOError - | ClosedHandle - | SemiClosedHandle Addr (Addr, Int) - | ReadHandle Addr (Maybe BufferMode) Bool - | WriteHandle Addr (Maybe BufferMode) Bool - | AppendHandle Addr (Maybe BufferMode) Bool - | ReadWriteHandle Addr (Maybe BufferMode) Bool - -instance Eq Handle{-partain:????-} - -{-# INLINE newHandle #-} -{-# INLINE readHandle #-} -{-# INLINE writeHandle #-} - -newHandle :: Handle__ -> IO Handle -readHandle :: Handle -> IO Handle__ -writeHandle :: Handle -> Handle__ -> IO () - -#if defined(__CONCURRENT_HASKELL__) - -type Handle = MVar Handle__ - -newHandle = newMVar -readHandle = takeMVar -writeHandle = putMVar - -#else -type Handle = MutableVar RealWorld Handle__ - -newHandle v = stToIO (newVar v) -readHandle h = stToIO (readVar h) -writeHandle h v = stToIO (writeVar h v) - -#endif {- __CONCURRENT_HASKELL__ -} - -type FilePath = String - -filePtr :: Handle__ -> Addr -filePtr (SemiClosedHandle fp _) = fp -filePtr (ReadHandle fp _ _) = fp -filePtr (WriteHandle fp _ _) = fp -filePtr (AppendHandle fp _ _) = fp -filePtr (ReadWriteHandle fp _ _) = fp - -bufferMode :: Handle__ -> Maybe BufferMode -bufferMode (ReadHandle _ m _) = m -bufferMode (WriteHandle _ m _) = m -bufferMode (AppendHandle _ m _) = m -bufferMode (ReadWriteHandle _ m _) = m - -markHandle :: Handle__ -> Handle__ -markHandle h@(ReadHandle fp m b) - | b = h - | otherwise = ReadHandle fp m True -markHandle h@(WriteHandle fp m b) - | b = h - | otherwise = WriteHandle fp m True -markHandle h@(AppendHandle fp m b) - | b = h - | otherwise = AppendHandle fp m True -markHandle h@(ReadWriteHandle fp m b) - | b = h - | otherwise = ReadWriteHandle fp m True - -------------------------------------------- - -stdin, stdout, stderr :: Handle - -stdin = unsafePerformPrimIO ( - _ccall_ getLock (``stdin''::Addr) 0 >>= \ rc -> - (case rc of - 0 -> new_handle ClosedHandle - 1 -> new_handle (ReadHandle ``stdin'' Nothing False) - _ -> constructError "stdin" >>= \ ioError -> - new_handle (ErrorHandle ioError) - ) >>= \ handle -> - returnPrimIO handle - ) - where - new_handle x = ioToST (newHandle x) - -stdout = unsafePerformPrimIO ( - _ccall_ getLock (``stdout''::Addr) 1 >>= \ rc -> - (case rc of - 0 -> new_handle ClosedHandle - 1 -> new_handle (WriteHandle ``stdout'' Nothing False) - _ -> constructError "stdout" >>= \ ioError -> - new_handle (ErrorHandle ioError) - ) >>= \ handle -> - returnPrimIO handle - ) - where - new_handle x = ioToST (newHandle x) - -stderr = unsafePerformPrimIO ( - _ccall_ getLock (``stderr''::Addr) 1 >>= \ rc -> - (case rc of - 0 -> new_handle ClosedHandle - 1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False) - _ -> constructError "stderr" >>= \ ioError -> - new_handle (ErrorHandle ioError) - ) >>= \ handle -> - returnPrimIO handle - ) - where - new_handle x = ioToST (newHandle x) -{- -\end{code} - -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. - -\subsubsection[OpeningClosing]{Opening and Closing Files} - -\begin{code} --} -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) - -openFile :: FilePath -> IOMode -> IO Handle - -openFile f m = - stToIO (_ccall_ openFile f m') >>= \ ptr -> - if ptr /= ``NULL'' then - newHandle (htype ptr Nothing False) - else - stToIO (constructError "openFile") >>= \ ioError -> - let - improved_error -- a HACK, I guess - = case ioError of - AlreadyExists msg -> AlreadyExists (msg ++ ": " ++ f) - NoSuchThing msg -> NoSuchThing (msg ++ ": " ++ f) - PermissionDenied msg -> PermissionDenied (msg ++ ": " ++ f) - _ -> ioError - in - fail improved_error - where - m' = case m of - ReadMode -> "r" - WriteMode -> "w" - AppendMode -> "a" - ReadWriteMode -> "r+" - - htype = case m of - ReadMode -> ReadHandle - WriteMode -> WriteHandle - AppendMode -> AppendHandle - ReadWriteMode -> ReadWriteHandle -{- -\end{code} - -Computation $openFile file mode$ allocates and returns a new, open -handle to manage the file {\em file}. It manages input if {\em mode} -is $ReadMode$, output if {\em 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 {\em 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 {\em 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. - -\begin{code} --} -hClose :: Handle -> IO () - -hClose handle = - readHandle handle >>= \ htype -> - writeHandle handle ClosedHandle >> - case htype of - ErrorHandle ioError -> - fail ioError - ClosedHandle -> - fail (IllegalOperation "handle is closed") - SemiClosedHandle fp (buf,_) -> - (if buf /= ``NULL'' then - _ccall_ free buf - else - returnPrimIO ()) `stThen` \ () -> - if fp /= ``NULL'' then - _ccall_ closeFile fp `stThen` \ rc -> - if rc == 0 then - return () - else - constructErrorAndFail "hClose" - else - return () - other -> - _ccall_ closeFile (filePtr other) `stThen` \ rc -> - if rc == 0 then - return () - else - constructErrorAndFail "hClose" -{- -\end{code} - -Computation $hClose hdl$ makes handle {\em hdl} closed. Before the -computation finishes, any items buffered for output and not already -sent to the operating system are flushed as for $flush$. - -\subsubsection[EOF]{Detecting the End of Input} - -\begin{code} --} -hFileSize :: Handle -> IO Integer -hFileSize handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - -- HACK! We build a unique MP_INT of the right shape to hold - -- a single unsigned word, and we let the C routine change the data bits - _casm_ ``%r = 1;'' `stThen` \ (I# hack#) -> - case int2Integer# hack# of - result@(J# _ _ d#) -> - let - bogus_bounds = (error "fileSize"::(Int,Int)) - in - _ccall_ fileSize (filePtr other) (ByteArray bogus_bounds d#) - `stThen` \ rc -> - writeHandle handle htype >> - if rc == 0 then - return result - else - constructErrorAndFail "hFileSize" -{- -\end{code} - -For a handle {\em hdl} which attached to a physical file, $hFileSize -hdl$ returns the size of {\em hdl} in terms of the number of items -which can be read from {\em hdl}. - -\begin{code} --} -hIsEOF :: Handle -> IO Bool -hIsEOF handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - WriteHandle _ _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") - other -> - _ccall_ fileEOF (filePtr other) `stThen` \ rc -> - writeHandle handle (markHandle htype) >> - case rc of - 0 -> return False - 1 -> return True - _ -> constructErrorAndFail "hIsEOF" - -isEOF :: IO Bool -isEOF = hIsEOF stdin -{- -\end{code} - -For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns -$True$ if no further input can be taken from {\em hdl} or for a -physical file, if the current I/O position is equal to the length of -the file. Otherwise, it returns $False$. - -\subsubsection[Buffering]{Buffering Operations} - -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: -\begin{itemize} -\item[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. - -\item[block-buffering] the entire output buffer is written out whenever -it overflows, a flush is issued, or the handle -is closed. - -\item[no-buffering] output is written immediately, and never stored -in the output buffer. -\end{itemize} - -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}. -\begin{itemize} -\item[line-buffering] when the input buffer for {\em hdl} 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. -\item[block-buffering] when the input buffer for {\em hdl} becomes empty, -the next block of data is read into this buffer. -\item[no-buffering] the next input item is read and returned. -\end{itemize} -For most implementations, physical files will normally be block-buffered -and terminals will normally be line-buffered. - -\begin{code} --} -data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Read, Show) - -hSetBuffering :: Handle -> BufferMode -> IO () - -hSetBuffering handle mode = - case mode of - (BlockBuffering (Just n)) - | n <= 0 -> fail (InvalidArgument "illegal buffer size") - other -> - readHandle handle >>= \ htype -> - if isMarked htype then - writeHandle handle htype >> - fail (UnsupportedOperation "can't set buffering for a dirty handle") - else - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - _ccall_ setBuffering (filePtr other) bsize - `stThen` \ rc -> - if rc == 0 then - writeHandle handle ((hcon other) (filePtr other) (Just mode) True) - >> - return () - else - writeHandle handle htype >> - constructErrorAndFail "hSetBuffering" - - where - isMarked :: Handle__ -> Bool - isMarked (ReadHandle fp m b) = b - isMarked (WriteHandle fp m b) = b - isMarked (AppendHandle fp m b) = b - isMarked (ReadWriteHandle fp m b) = b - - bsize :: Int - bsize = case mode of - NoBuffering -> 0 - LineBuffering -> -1 - BlockBuffering Nothing -> -2 - BlockBuffering (Just n) -> n - - hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__) - hcon (ReadHandle _ _ _) = ReadHandle - hcon (WriteHandle _ _ _) = WriteHandle - hcon (AppendHandle _ _ _) = AppendHandle - hcon (ReadWriteHandle _ _ _) = ReadWriteHandle -{- -\end{code} - -Computation $hSetBuffering hdl mode$ sets the mode of buffering for -handle {\em hdl} on subsequent reads and writes. - -\begin{itemize} -\item -If {\em mode} is $LineBuffering$, line-buffering should be -enabled if possible. -\item -If {\em mode} is $BlockBuffering$ {\em size}, then block-buffering -should be enabled if possible. The size of the buffer is {\em n} items -if {\em size} is $Just${\em n} and is otherwise implementation-dependent. -\item -If {\em mode} is $NoBuffering$, then buffering is disabled if possible. -\end{itemize} - -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. - -\begin{code} --} -hFlush :: Handle -> IO () -hFlush handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - _ccall_ flushFile (filePtr other) `stThen` \ rc -> - writeHandle handle (markHandle htype) >> - if rc == 0 then - return () - else - constructErrorAndFail "hFlush" -{- -\end{code} - -Computation $flush hdl$ causes any items -buffered for output in handle {\em hdl} to be sent immediately to -the operating system. - -\subsubsection[Seeking]{Repositioning Handles} - -\begin{code} --} -data HandlePosn = HandlePosn Handle Int - -instance Eq HandlePosn{-partain-} - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - _ccall_ getFilePosn (filePtr other) `stThen` \ posn -> - writeHandle handle htype >> - if posn /= -1 then - return (HandlePosn handle posn) - else - constructErrorAndFail "hGetPosn" - -hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn handle posn) = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is not seekable") - other -> - _ccall_ setFilePosn (filePtr other) posn `stThen` \ rc -> - writeHandle handle (markHandle htype) >> - if rc == 0 then - return () - else - constructErrorAndFail "hSetPosn" -{- -\end{code} - -Computation $hGetPosn hdl$ returns the current I/O -position of {\em hdl} as an abstract position. Computation -$hSetPosn p$ sets the position of {\em hdl} -to a previously obtained position {\em p}. - -\begin{code} --} -data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd - deriving (Eq, Ord, Ix, Enum, Read, Show) - -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset@(J# _ s# d#) = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - AppendHandle _ _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is not seekable") - other -> - _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#) - `stThen` \ rc -> - writeHandle handle (markHandle htype) >> - if rc == 0 then - return () - else - constructErrorAndFail "hSeek" - where - whence :: Int - whence = case mode of - AbsoluteSeek -> ``SEEK_SET'' - RelativeSeek -> ``SEEK_CUR'' - SeekFromEnd -> ``SEEK_END'' -{- -\end{code} - -Computation $hSeek hdl mode i$ sets the position of handle -{\em hdl} depending on $mode$. If {\em mode} is -\begin{itemize} -\item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}. -\item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from -the current position. -\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from -the end of the file. -\item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from -the beginning of the file. -\end{itemize} - -Some handles may not be seekable $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. - -\subsubsection[Query]{Handle Properties} - -\begin{code} --} -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - return False - SemiClosedHandle _ _ -> - writeHandle handle htype >> - return False - other -> - writeHandle handle htype >> - return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - return True - other -> - writeHandle handle htype >> - return False - -hIsReadable :: Handle -> IO Bool -hIsReadable handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - writeHandle handle htype >> - return (isReadable other) - where - isReadable (ReadHandle _ _ _) = True - isReadable (ReadWriteHandle _ _ _) = True - isReadable _ = False - -hIsWritable :: Handle -> IO Bool -hIsWritable handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - writeHandle handle htype >> - return (isWritable other) - where - isWritable (AppendHandle _ _ _) = True - isWritable (WriteHandle _ _ _) = True - isWritable (ReadWriteHandle _ _ _) = True - isWritable _ = False - -getBufferMode :: Handle__ -> PrimIO Handle__ -getBufferMode htype = - case bufferMode htype of - Just x -> returnPrimIO htype - Nothing -> - _ccall_ getBufferMode (filePtr htype) `thenPrimIO` \ rc -> - let - mode = - case rc of - 0 -> Just NoBuffering - -1 -> Just LineBuffering - -2 -> Just (BlockBuffering Nothing) - -3 -> Nothing - n -> Just (BlockBuffering (Just n)) - in - returnPrimIO (case htype of - ReadHandle fp _ b -> ReadHandle fp mode b - WriteHandle fp _ b -> WriteHandle fp mode b - AppendHandle fp _ b -> AppendHandle fp mode b - ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b) - -hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int) -hIsBlockBuffered handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - getBufferMode other `stThen` \ other -> - case bufferMode other of - Just (BlockBuffering size) -> - writeHandle handle other >> - return (True, size) - Just _ -> - writeHandle handle other >> - return (False, Nothing) - Nothing -> - constructErrorAndFail "hIsBlockBuffered" - -hIsLineBuffered :: Handle -> IO Bool -hIsLineBuffered handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - getBufferMode other `stThen` \ other -> - case bufferMode other of - Just LineBuffering -> - writeHandle handle other >> - return True - Just _ -> - writeHandle handle other >> - return False - Nothing -> - constructErrorAndFail "hIsLineBuffered" - -hIsNotBuffered :: Handle -> IO Bool -hIsNotBuffered handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - other -> - getBufferMode other `stThen` \ other -> - case bufferMode other of - Just NoBuffering -> - writeHandle handle other >> - return True - Just _ -> - writeHandle handle other >> - return False - Nothing -> - constructErrorAndFail "hIsNotBuffered" - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering hndl = - readHandle hndl >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle hndl htype >> - fail ioError - ClosedHandle -> - writeHandle hndl htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle hndl htype >> - fail (IllegalOperation "handle is closed") - other -> - getBufferMode other `stThen` \ other -> - case bufferMode other of - Just v -> - writeHandle hndl other >> - return v - Nothing -> - constructErrorAndFail "hGetBuffering" - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - readHandle handle >>= \ htype -> - case htype of - ErrorHandle ioError -> - writeHandle handle htype >> - fail ioError - ClosedHandle -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - SemiClosedHandle _ _ -> - writeHandle handle htype >> - fail (IllegalOperation "handle is closed") - AppendHandle _ _ _ -> - writeHandle handle htype >> - return False - other -> - _ccall_ seekFileP (filePtr other) `stThen` \ rc -> - writeHandle handle htype >> - case rc of - 0 -> return False - 1 -> return True - _ -> constructErrorAndFail "hIsSeekable" -{- -\end{code} - -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. - -Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if -{\em hdl} is not block-buffered. Otherwise it returns -$( True, size )$, where {\em size} is $Nothing$ for default buffering, and -$( Just n )$ for block-buffering of {\em n} bytes. --} - -------------------------------------------------------------------- -data IOError - = AlreadyExists String - | HardwareFault String - | IllegalOperation String - | InappropriateType String - | Interrupted String - | InvalidArgument String - | NoSuchThing String - | OtherError String - | PermissionDenied String - | ProtocolError String - | ResourceBusy String - | ResourceExhausted String - | ResourceVanished String - | SystemError String - | TimeExpired String - | UnsatisfiedConstraints String - | UnsupportedOperation String - | UserError String - | EOF - -instance Eq IOError where - -- I don't know what the (pointless) idea is here, - -- presumably just compare them by their tags (WDP) - a == b = tag a == tag b - where - tag (AlreadyExists _) = (1::Int) - tag (HardwareFault _) = 2 - tag (IllegalOperation _) = 3 - tag (InappropriateType _) = 4 - tag (Interrupted _) = 5 - tag (InvalidArgument _) = 6 - tag (NoSuchThing _) = 7 - tag (OtherError _) = 8 - tag (PermissionDenied _) = 9 - tag (ProtocolError _) = 10 - tag (ResourceBusy _) = 11 - tag (ResourceExhausted _) = 12 - tag (ResourceVanished _) = 13 - tag (SystemError _) = 14 - tag (TimeExpired _) = 15 - tag (UnsatisfiedConstraints _) = 16 - tag (UnsupportedOperation _) = 17 - tag (UserError _) = 18 - tag EOF = 19 - -instance Show IOError where - showsPrec p (AlreadyExists s) = show2 "AlreadyExists: " s - showsPrec p (HardwareFault s) = show2 "HardwareFault: " s - showsPrec p (IllegalOperation s) = show2 "IllegalOperation: " s - showsPrec p (InappropriateType s) = show2 "InappropriateType: " s - showsPrec p (Interrupted s) = show2 "Interrupted: " s - showsPrec p (InvalidArgument s) = show2 "InvalidArgument: " s - showsPrec p (NoSuchThing s) = show2 "NoSuchThing: " s - showsPrec p (OtherError s) = show2 "OtherError: " s - showsPrec p (PermissionDenied s) = show2 "PermissionDenied: " s - showsPrec p (ProtocolError s) = show2 "ProtocolError: " s - showsPrec p (ResourceBusy s) = show2 "ResourceBusy: " s - showsPrec p (ResourceExhausted s) = show2 "ResourceExhausted: " s - showsPrec p (ResourceVanished s) = show2 "ResourceVanished: " s - showsPrec p (SystemError s) = show2 "SystemError: " s - showsPrec p (TimeExpired s) = show2 "TimeExpired: " s - showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s - showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s - showsPrec p (UserError s) = showString s - showsPrec p EOF = showString "EOF" - -show2 x y = showString x . showString y - -{- - -The @String@ part of an @IOError@ is platform-dependent. However, to -provide a uniform mechanism for distinguishing among errors within -these broad categories, each platform-specific standard shall specify -the exact strings to be used for particular errors. For errors not -explicitly mentioned in the standard, any descriptive string may be -used. - - SOF 4/96 - added argument to indicate function that flagged error --} -constructErrorAndFail :: String -> IO a -constructError :: String -> PrimIO IOError - -constructErrorAndFail call_site - = stToIO (constructError call_site) >>= \ io_error -> - fail io_error - -constructError call_site - = _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> - _casm_ ``%r = ghc_errstr;'' >>= \ str -> - let - msg = call_site ++ ':' : ' ' : GHCps.unpackPS (GHCps.packCString str) - in - return (case errtype# of - ERR_ALREADYEXISTS# -> AlreadyExists msg - ERR_HARDWAREFAULT# -> HardwareFault msg - ERR_ILLEGALOPERATION# -> IllegalOperation msg - ERR_INAPPROPRIATETYPE# -> InappropriateType msg - ERR_INTERRUPTED# -> Interrupted msg - ERR_INVALIDARGUMENT# -> InvalidArgument msg - ERR_NOSUCHTHING# -> NoSuchThing msg - ERR_OTHERERROR# -> OtherError msg - ERR_PERMISSIONDENIED# -> PermissionDenied msg - ERR_PROTOCOLERROR# -> ProtocolError msg - ERR_RESOURCEBUSY# -> ResourceBusy msg - ERR_RESOURCEEXHAUSTED# -> ResourceExhausted msg - ERR_RESOURCEVANISHED# -> ResourceVanished msg - ERR_SYSTEMERROR# -> SystemError msg - ERR_TIMEEXPIRED# -> TimeExpired msg - ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints msg - ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation msg - ERR_EOF# -> EOF - _ -> OtherError "bad error construct" - ) diff --git a/ghc/lib/prelude/GHCmain.hs b/ghc/lib/prelude/GHCmain.hs deleted file mode 100644 index bb8f19f..0000000 --- a/ghc/lib/prelude/GHCmain.hs +++ /dev/null @@ -1,29 +0,0 @@ --- This is the mainPrimIO that must be used for Haskell~1.3. - -module GHCmain ( mainPrimIO ) where - -import qualified Main -- for type of "Main.main" -import GHCbase - -mainPrimIO :: PrimIO () - -mainPrimIO = ST $ \ s -> - case Main.main of { IO (ST main_guts) -> - case main_guts s of { (result, s2@(S# _)) -> - case result of - Right () -> ( (), s2 ) - Left err -> error ("I/O error: "++showsPrec 0 err "\n") - }} - -{- -OLD COMMENT: - -Nota Bene! @mainIO@ is written as an explicit function, rather than -by saying: @mainIO = requestToIO main@ so that the code generator -recognises @mainIO@ as a {\em function} (hence HNF, hence not -updatable), rather than a zero-arity CAF (hence updatable). If it is -updated, then we have a mega-space leak, because the entire action -(@requestToIO main@) is retained indefinitely. - -(This doesn't waste work because @mainIO@ is only used once.) --} diff --git a/ghc/lib/prelude/GHCps.hs b/ghc/lib/prelude/GHCps.hs deleted file mode 100644 index 1d1255f..0000000 --- a/ghc/lib/prelude/GHCps.hs +++ /dev/null @@ -1,1007 +0,0 @@ -{- -% -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996 -% -\section{Packed strings} - -This sits on top of the sequencing/arrays world, notably @ByteArray#@s. - -Glorious hacking (all the hard work) by Bryan O'Sullivan. - -\begin{code} --} -module GHCps ( - - packString, -- :: [Char] -> PackedString - packStringST, -- :: [Char] -> ST s PackedString - packCString, -- :: Addr -> PackedString - packCBytes, -- :: Int -> Addr -> PackedString - packCBytesST, -- :: Int -> Addr -> ST s PackedString - packStringForC, -- :: [Char] -> ByteArray# - packBytesForC, -- :: [Char] -> ByteArray Int - packBytesForCST, -- :: [Char] -> ST s (ByteArray Int) - nilPS, -- :: PackedString - consPS, -- :: Char -> PackedString -> PackedString - - byteArrayToPS, -- :: ByteArray Int -> PackedString - unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString - psToByteArray, -- :: PackedString -> ByteArray Int - - unpackPS, -- :: PackedString -> [Char] -{-LATER: - hPutPS, -- :: Handle -> PackedString -> IO () - putPS, -- :: FILE -> PackedString -> PrimIO () -- ToDo: more sensible type - getPS, -- :: FILE -> Int -> PrimIO 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 - ) where - -import Ix ( Ix(..) ) -import Char ( isSpace ) -import GHCbase -{- -\end{code} - -%************************************************************************ -%* * -\subsection{@PackedString@ type declaration} -%* * -%************************************************************************ - -The type comes from GHCbase; we re-export it abstractly. - -%************************************************************************ -%* * -\subsection{@PackedString@ instances} -%* * -%************************************************************************ - -We try hard to make this go fast: -\begin{code} --} -comparePS :: PackedString -> PackedString -> Ordering - -comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2) - | not has_null1 && not has_null2 - = unsafePerformPrimIO ( - _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 len2) - | not has_null1 - = unsafePerformPrimIO ( - _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 = A# bs2 - -comparePS (CPS bs1 len1) (CPS bs2 len2) - = unsafePerformPrimIO ( - _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> - return ( - if res <# 0# then LT - else if res ==# 0# then EQ - else GT - )) - where - ba1 = A# bs1 - ba2 = A# 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 - -{- -\end{code} -%************************************************************************ -%* * -\subsection{Constructor functions} -%* * -%************************************************************************ - -Easy ones first. @packString@ requires getting some heap-bytes and -scribbling stuff into them. - -\begin{code} --} -packCString :: Addr -> PackedString -packCString (A# a#) = -- the easy one; we just believe the caller - CPS a# len - where - len = case (strlen# a#) of { I# x -> x } - -nilPS :: PackedString -nilPS = CPS ""# 0# - -consPS :: Char -> PackedString -> PackedString -consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better - -packStringForC :: [Char] -> ByteArray# -packStringForC = packStringForC__ -- from GHCbase - -packBytesForC :: [Char] -> ByteArray Int -packBytesForC str = psToByteArray (packString str) - -packBytesForCST :: [Char] -> ST s (ByteArray Int) -packBytesForCST str = - packStringST str >>= \ (PS bytes n has_null) -> - --later? ASSERT(not has_null) - return (ByteArray (0, I# (n -# 1#)) bytes) - -packNBytesForCST :: Int -> [Char] -> ST s (ByteArray Int) -packNBytesForCST len str = - packNCharsST len str >>= \ (PS bytes n has_null) -> - return (ByteArray (0, I# (n -# 1#)) bytes) - -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 len@(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 >>= \ (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 - -packCBytes :: Int -> Addr -> PackedString -packCBytes len addr = runST (packCBytesST len addr) - -packCBytesST :: Int -> Addr -> ST s PackedString -packCBytesST len@(I# length#) (A# 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 >>= \ (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#) } - -byteArrayToPS :: ByteArray Int -> PackedString -byteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) = - let - n# = - case ( - if null (range ixs) - then 0 - else ((index ixs ix_end) + 1) - ) of { I# x -> x } - in - PS frozen# n# (byteArrayHasNUL# frozen# n#) - -unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString -unsafeByteArrayToPS (ByteArray _ frozen#) (I# n#) - = PS frozen# n# (byteArrayHasNUL# frozen# n#) - -psToByteArray :: PackedString -> ByteArray Int -psToByteArray (PS bytes n has_null) - = ByteArray (0, I# (n -# 1#)) bytes - -psToByteArray (CPS addr len#) - = let - len = I# len# - byte_array_form = packCBytes len (A# addr) - in - case byte_array_form of { PS bytes _ _ -> - ByteArray (0, len - 1) bytes } -{- -\end{code} - -%************************************************************************ -%* * -\subsection{Destructor functions (taking @PackedStrings@ apart)} -%* * -%************************************************************************ - -\begin{code} --} --- OK, but this code gets *hammered*: --- unpackPS ps --- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ] - -unpackPS :: PackedString -> [Char] -unpackPS (PS bytes len has_null) - = unpack 0# - where - unpack nh - | nh >=# len = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharArray# bytes nh - -unpackPS (CPS addr len) - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh -{- -\end{code} - -Output a packed string via a handle: - -\begin{code} --} -{- LATER: -hPutPS :: Handle -> PackedString -> IO () -hPutPS handle ps = - let - len = - case ps of - PS _ len _ -> len - CPS _ len -> len - in - if len ==# 0# then - return () - else - _readHandle handle >>= \ htype -> - case htype of - _ErrorHandle ioError -> - _writeHandle handle htype >> - failWith ioError - _ClosedHandle -> - _writeHandle handle htype >> - failWith (IllegalOperation "handle is closed") - _SemiClosedHandle _ _ -> - _writeHandle handle htype >> - failWith (IllegalOperation "handle is closed") - _ReadHandle _ _ _ -> - _writeHandle handle htype >> - failWith (IllegalOperation "handle is not open for writing") - other -> - _getBufferMode other >>= \ other -> - (case _bufferMode other of - Just LineBuffering -> - writeLines (_filePtr other) - Just (BlockBuffering (Just size)) -> - writeBlocks (_filePtr other) size - Just (BlockBuffering Nothing) -> - writeBlocks (_filePtr other) ``BUFSIZ'' - _ -> -- Nothing is treated pessimistically as NoBuffering - writeChars (_filePtr other) 0# - ) >>= \ success -> - _writeHandle handle (_markHandle other) >> - if success then - return () - else - _constructError "hPutStr" >>= \ ioError -> - failWith ioError - - where - pslen = lengthPS# ps - - writeLines :: Addr -> PrimIO Bool - writeLines = writeChunks ``BUFSIZ'' True - - writeBlocks :: Addr -> Int -> PrimIO Bool - writeBlocks fp size = writeChunks size False fp - - {- - The breaking up of output into lines along \n boundaries - works fine as long as there are newlines to split by. - Avoid the splitting up into lines altogether (doesn't work - for overly long lines like the stuff that showsPrec instances - normally return). Instead, we split them up into fixed size - chunks before blasting them off to the Real World. - - Hacked to avoid multiple passes over the strings - unsightly, but - a whole lot quicker. -- SOF 3/96 - -} - - writeChunks :: Int -> Bool -> Addr -> PrimIO Bool - writeChunks (I# bufLen) chopOnNewLine fp = - newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) -> - let - shoveString :: Int# -> Int# -> PrimIO Bool - shoveString n i - | i ==# pslen = -- end of string - if n ==# 0# then - return True - else - _ccall_ writeFile arr fp (I# n) >>= \rc -> - return (rc==0) - | otherwise = - (\ (S# s#) -> - case writeCharArray# arr# n (indexPS# ps i) s# of - s1# -> - {- Flushing lines - should we bother? -} - (if n ==# bufLen then - _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \rc -> - if rc == 0 then - shoveString 0# (i +# 1#) - else - return False - else - shoveString (n +# 1#) (i +# 1#)) (S# s1#)) - in - shoveString 0# 0# - - writeChars :: Addr -> Int# -> PrimIO Bool - writeChars fp i - | i ==# pslen = return True - | otherwise = - _ccall_ filePutc fp (ord (C# (indexPS# ps i))) >>= \ rc -> - if rc == 0 then - writeChars fp (i +# 1#) - else - return False - ---------------------------------------------- - -putPS :: _FILE -> PackedString -> PrimIO () -putPS file ps@(PS bytes len has_null) - | len ==# 0# - = return () - | otherwise - = let - byte_array = ByteArray (0, I# (len -# 1#)) bytes - in - _ccall_ fwrite byte_array (1::Int){-size-} (I# len) file - >>= \ (I# written) -> - if written ==# len then - return () - else - error "GHCps.putPS: fwrite failed!\n" - -putPS file (CPS addr len) - | len ==# 0# - = return () - | otherwise - = _ccall_ fputs (A# addr) file >>= \ (I# _){-force type-} -> - return () -{- -\end{code} - -The dual to @_putPS@, note that the size of the chunk specified -is the upper bound of the size of the chunk returned. - -\begin{code} --} -getPS :: _FILE -> Int -> PrimIO PackedString -getPS file len@(I# len#) - | len# <=# 0# = return nilPS -- I'm being kind here. - | otherwise = - -- Allocate an array for system call to store its bytes into. - new_ps_array len# >>= \ ch_arr -> - freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) -> - let - byte_array = ByteArray (0, I# len#) frozen# - in - _ccall_ fread byte_array (1::Int) len file >>= \ (I# read#) -> - if read# ==# 0# then -- EOF or other error - error "GHCps.getPS: 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) -END LATER -} -{- -\end{code} - -%************************************************************************ -%* * -\subsection{List-mimicking functions for @PackedStrings@} -%* * -%************************************************************************ - -First, the basic functions that do look into the representation; -@indexPS@ is the most important one. -\begin{code} --} -lengthPS :: PackedString -> Int -lengthPS ps = I# (lengthPS# ps) - -{-# INLINE lengthPS# #-} - -lengthPS# (PS _ i _) = i -lengthPS# (CPS _ i) = i - -{-# INLINE strlen# #-} - -strlen# :: Addr# -> Int -strlen# a - = unsafePerformPrimIO ( - _ccall_ strlen (A# a) >>= \ len@(I# _) -> - return len - ) - -byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool -byteArrayHasNUL# bs len - = unsafePerformPrimIO ( - _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# (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 -{- -\end{code} - -Now, the rest of the functions can be defined without digging -around in the representation. - -\begin{code} --} -headPS :: PackedString -> Char -headPS ps - | nullPS ps = error "GHCps.headPS: head []" - | otherwise = C# (indexPS# ps 0#) - -tailPS :: PackedString -> PackedString -tailPS ps - | len <=# 0# = error "GHCps.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# - -{- (ToDo: some non-lousy implementations...) - - Old : _appendPS xs ys = packString (unpackPS xs ++ unpackPS ys) - --} -appendPS :: PackedString -> PackedString -> PackedString -appendPS xs ys - | nullPS xs = ys - | nullPS ys = xs - | otherwise = concatPS [xs,ys] - -{- OLD: mapPS f xs = packString (map f (unpackPS xs)) -} - -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 >>= \ (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# 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 >>= \ (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 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 b ps - = if nullPS ps then - b - else - whizzRL b 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 = ps - | 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 - -char_pos_that_dissatisfies p ps len pos -- dead code: HACK to avoid badly-typed error msg - = 0# - -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# >>= \ (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 } - tot_len = I# tot_len# - in - runST ( - new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte! - packum arr# pss 0# >> - freeze_ps_array arr# >>= \ (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#) -{- -\end{code} - -%************************************************************************ -%* * -\subsection{Local utility functions} -%* * -%************************************************************************ - -The definition of @_substrPS@ is essentially: -@take (end - begin + 1) (drop begin str)@. -\begin{code} --} -substrPS :: PackedString -> Int -> Int -> PackedString -substrPS ps (I# begin) (I# end) = substrPS# ps begin end - -substrPS# ps s e - | s <# 0# || e <# s - = error "GHCps.substrPS: bounds out of range" - - | 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 >>= \ (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 - result_len = I# result_len# - - ----------------------- - 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#) -{- -\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 -> ST s (ByteArray Int) - -new_ps_array size = ST $ \ (S# s) -> - case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# -> - (MutableByteArray bot barr#, S# s2#)} - where - bot = error "new_ps_array" - -write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ (S# s#) -> - case writeCharArray# barr# n ch s# of { s2# -> - ((), S# s2#)} - --- same as unsafeFreezeByteArray -freeze_ps_array (MutableByteArray ixs arr#) = ST $ \ (S# s#) -> - case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> - (ByteArray ixs frozen#, S# s2#) } diff --git a/ghc/lib/prelude/Main.mc_hi b/ghc/lib/prelude/Main.mc_hi deleted file mode 100644 index 8ed9e1a..0000000 --- a/ghc/lib/prelude/Main.mc_hi +++ /dev/null @@ -1,5 +0,0 @@ -interface Main 1 -__exports__ -Main main (..) -__declarations__ -Main.main :: GHCbase.IO Prelude.(); diff --git a/ghc/lib/prelude/Main.mg_hi b/ghc/lib/prelude/Main.mg_hi deleted file mode 100644 index 8ed9e1a..0000000 --- a/ghc/lib/prelude/Main.mg_hi +++ /dev/null @@ -1,5 +0,0 @@ -interface Main 1 -__exports__ -Main main (..) -__declarations__ -Main.main :: GHCbase.IO Prelude.(); diff --git a/ghc/lib/prelude/Main.mp_hi b/ghc/lib/prelude/Main.mp_hi deleted file mode 100644 index 8ed9e1a..0000000 --- a/ghc/lib/prelude/Main.mp_hi +++ /dev/null @@ -1,5 +0,0 @@ -interface Main 1 -__exports__ -Main main (..) -__declarations__ -Main.main :: GHCbase.IO Prelude.(); diff --git a/ghc/lib/prelude/Main.p_hi b/ghc/lib/prelude/Main.p_hi deleted file mode 100644 index 8ed9e1a..0000000 --- a/ghc/lib/prelude/Main.p_hi +++ /dev/null @@ -1,5 +0,0 @@ -interface Main 1 -__exports__ -Main main (..) -__declarations__ -Main.main :: GHCbase.IO Prelude.(); diff --git a/ghc/lib/prelude/Prelude.hs b/ghc/lib/prelude/Prelude.hs deleted file mode 100644 index 7bf33a9..0000000 --- a/ghc/lib/prelude/Prelude.hs +++ /dev/null @@ -1,1710 +0,0 @@ -module Prelude ( - -#include "../includes/ieee-flpt.h" - ---partain: module PreludeList, - 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, - lines, words, unlines, unwords, reverse, and, or, - any, all, elem, notElem, lookup, - sum, product, maximum, minimum, concatMap, - zip, zip3, zipWith, zipWith3, unzip, unzip3, - ---partain:module PreludeText, - ReadS, ShowS, - Read(readsPrec, readList), - Show(showsPrec, showList), - reads, shows, show, read, lex, - showChar, showString, readParen, showParen, ---partain:module PreludeIO, - FilePath, IOError, fail, userError, catch, - putChar, putStr, putStrLn, print, - getChar, getLine, getContents, interact, - readFile, writeFile, appendFile, readIO, readLn, - - Bool(False, True), - Maybe(Nothing, Just), - Either(Left, Right), either, - Ordering(LT, EQ, GT), - Char, String, Int, Integer, Float, Double, IO, Void, - [](..), -- List type - ()(..), -- Trivial type - -- Tuple types: (,), (,,), etc. - (,)(..), - (,,)(..), - (,,,)(..), - (,,,,)(..), - (,,,,,)(..), - (,,,,,,)(..), - (,,,,,,,)(..), - (,,,,,,,,)(..), - (,,,,,,,,,)(..), - (,,,,,,,,,,)(..), - (,,,,,,,,,,,)(..), - (,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), - (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)(..), --- Functions: (->) - Eq((==), (/=)), - Ord(compare, (<), (<=), (>=), (>), max, min), - Enum(toEnum, fromEnum, enumFrom, enumFromThen, - enumFromTo, enumFromThenTo), - Bounded(minBound, maxBound), - Eval(..{-seq, strict-}), seq, strict, -- NB: glasgow hack - Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt{-partain-}), - Real(toRational), - Integral(quot, rem, div, mod, quotRem, divMod, toInteger, toInt{-partain-}), - Fractional((/), recip, fromRational), - Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, - asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), - RealFrac(properFraction, truncate, round, ceiling, floor), - RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, - encodeFloat, exponent, significand, scaleFloat, isNaN, - isInfinite, isDenormalized, isIEEE, isNegativeZero), - Monad((>>=), (>>), return), - MonadZero(zero), - MonadPlus((++)), - Functor(map), - succ, pred, - mapM, mapM_, guard, accumulate, sequence, filter, concat, applyM, - maybe, - (&&), (||), not, otherwise, - subtract, even, odd, gcd, lcm, (^), (^^), - fromIntegral, fromRealFrac, atan2, - fst, snd, curry, uncurry, id, const, (.), flip, ($), until, - asTypeOf, error, undefined ) where - -import GHCbase -- all the GHC basics -import GHCio -- I/O basics -import Ratio(Ratio, Rational, (%), numerator, denominator) - ---PreludeText: -import Char ( isSpace ) -import IO ( hPutChar, hPutStr, hGetChar, hGetContents ) - -infixl 9 !! -infix 4 `elem`, `notElem` -{- :PreludeList -} - -infixr 9 . -infixr 8 ^, ^^, ** -infixl 7 *, /, `quot`, `rem`, `div`, `mod` -infixl 6 +, - -infixr 5 :, ++ -infix 4 ==, /=, <, <=, >=, > -infixr 3 && -infixr 2 || -infixr 1 >>, >>= -infixr 0 $ - --- Standard types, classes, instances and related functions - --- Equality and Ordered classes - -class Eq a where - (==), (/=) :: a -> a -> Bool - - 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 - | otherwise = GT - - 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 } - --- Enumeration and Bounded classes - -class (Ord a) => Enum a where - 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] - - enumFromTo n m = takeWhile (<= m) (enumFrom n) - enumFromThenTo n n' m - = takeWhile (if n' >= n then (<= m) else (>= m)) - (enumFromThen n n') - -succ, pred :: Enum a => a -> a -succ = toEnum . (+1) . fromEnum -pred = toEnum . (subtract 1) . fromEnum - -class Bounded a where - minBound, maxBound :: a - --- Numeric classes - -class (Eq a, Show a, Eval a) => Num a where - (+), (-), (*) :: a -> a -> a - negate :: a -> a - abs, signum :: a -> a - fromInteger :: Integer -> a - fromInt :: Int -> a -- partain: Glasgow extension - - x - y = x + negate y - fromInt i = fromInteger (int2Integer i) - where - int2Integer (I# i#) = int2Integer# i# - -- Go via the standard class-op if the - -- non-standard one ain't provided - -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 - toInt :: a -> Int -- partain: Glasgow extension - - n `quot` d = q where (q,r) = quotRem n d - n `rem` d = r where (q,r) = quotRem n d - n `div` d = q where (q,r) = divMod n d - n `mod` d = r where (q,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 - -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 (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 - -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 - - 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 - --- Numeric functions - -{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-} -subtract :: (Num a) => a -> a -> a -subtract x y = y - x - -even, odd :: (Integral a) => a -> Bool -even n = n `rem` 2 == 0 -odd = not . even - -{-# GENERATE_SPECS gcd a{Int#,Int,Integer} #-} -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' x 0 = x - gcd' x y = gcd' y (x `rem` y) - -{-# GENERATE_SPECS lcm a{Int#,Int,Integer} #-} -lcm :: (Integral a) => a -> a -> a -lcm _ 0 = 0 -lcm 0 _ = 0 -lcm x y = abs ((x `quot` (gcd x y)) * y) - -(^) :: (Num a, Integral b) => a -> b -> a -x ^ 0 = 1 -x ^ n | n > 0 = f x (n-1) x - where f _ 0 y = y - f x n y = g x n where - g x n | even n = g (x*x) (n `quot` 2) - | otherwise = f x (n-1) (x*y) -_ ^ _ = error "Prelude.^: negative exponent" - -(^^) :: (Fractional a, Integral b) => a -> b -> a -x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) - -fromIntegral :: (Integral a, Num b) => a -> b -fromIntegral = fromInteger . toInteger - -fromRealFrac :: (RealFrac a, Fractional b) => a -> b -fromRealFrac = fromRational . toRational - -atan2 :: (RealFloat a) => a -> a -> a -atan2 y x = case (signum y, signum x) of - ( 0, 1) -> 0 - ( 1, 0) -> pi/2 - ( 0,-1) -> pi - (-1, 0) -> (negate pi)/2 - ( _, 1) -> atan (y/x) - ( _,-1) -> atan (y/x) + pi - ( 0, 0) -> error "Prelude.atan2: atan2 of origin" - - --- Monadic classes - -class Functor f where - map :: (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 - - m >> k = m >>= \_ -> k - -class (Monad m) => MonadZero m where - zero :: m a - -class (MonadZero m) => MonadPlus m where - (++) :: m a -> m a -> m a - -accumulate :: Monad m => [m a] -> m [a] -accumulate [] = return [] -accumulate (m:ms) = do { x <- m; xs <- accumulate ms; return (x:xs) } -{- partain: this may be right, but I'm going w/ a more-certainly-right version -accumulate = foldr mcons (return []) - where mcons p q = p >>= \x -> q >>= \y -> return (x:y) --} -sequence :: Monad m => [m a] -> m () -sequence = foldr (>>) (return ()) - -mapM :: Monad m => (a -> m b) -> [a] -> m [b] -mapM f as = accumulate (map f as) - -mapM_ :: Monad m => (a -> m b) -> [a] -> m () -mapM_ f as = sequence (map f as) - -guard :: MonadZero m => Bool -> m () -guard p = if p then return () else zero - --- This subsumes the list-based filter function. - -filter :: MonadZero m => (a -> Bool) -> m a -> m a -filter p = applyM (\x -> if p x then return x else zero) - --- This subsumes the list-based concat function. - -concat :: MonadPlus m => [m a] -> m a -concat = foldr (++) zero - -applyM :: Monad m => (a -> m b) -> m a -> m b -applyM f x = x >>= f - - --- Eval Class - -class Eval a {-not Glasgow: where - seq :: a -> b -> b - strict :: (a -> b) -> a -> b - strict f x = x `seq` f x -} - --- seq: in GHCbase -strict :: Eval a => (a -> b) -> a -> b -strict f x = x `seq` f x - ---------------------------------------------------------------- --- Trivial type - -data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Bounded) - -- (avoids weird-named functions, e.g., con2tag_()# - -instance CReturnable () -- Why, exactly? - -instance Eq () where - () == () = True - () /= () = False - -instance Ord () where - () <= () = True - () < () = False - () >= () = True - () > () = False - max () () = () - min () () = () - compare () () = EQ - -instance Enum () where - toEnum 0 = () - toEnum _ = error "Prelude.Enum.().toEnum: argument not 0" - fromEnum () = 0 - enumFrom () = [()] - enumFromThen () () = [()] - enumFromTo () () = [()] - enumFromThenTo () () () = [()] - -instance Bounded () where - minBound = () - maxBound = () - -instance Show () where - showsPrec p () = showString "()" - -instance Read () where - readsPrec p = readParen False - (\r -> [((),t) | ("(",s) <- lex r, - (")",t) <- lex s ] ) - ---------------------------------------------------------------- --- Function type - ---data a -> b -- No constructor for functions is exported. - -instance Show (a -> b) where - showsPrec p f = showString "<>" - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- --- Empty type - ---partain:data Void -- No constructor for Void is exported. Import/Export - -- lists must use Void instead of Void(..) or Void() - ---------------------------------------------------------------- --- Boolean type - -data Bool = False | True deriving (Eq, Ord, Enum, Read, Show, Bounded) - --- 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 - ---------------------------------------------------------------- --- Character type - -data Char = C# Char# deriving (Eq, Ord) ---partain:data Char = ... 'a' | 'b' ... -- 265 ISO values -instance CCallable Char -instance CReturnable Char - -instance Enum Char where - toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i) - | otherwise = error "Prelude.Enum.Char.toEnum:out of range" - fromEnum (C# c) = I# (ord# c) - enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)] - enumFromThen c c' = map toEnum [fromEnum c, - fromEnum c' .. fromEnum lastChar] - where lastChar :: Char - lastChar | c' < c = minBound - | otherwise = maxBound - -instance Bounded Char where - minBound = '\0' - maxBound = '\255' - -instance Read Char where - readsPrec p = readParen False - (\r -> [(c,t) | ('\'':s,t)<- lex r, - (c,_) <- readLitChar s]) - - readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, - (l,_) <- readl s ]) - where readl ('"':s) = [("",s)] - readl ('\\':'&':s) = readl s - readl s = [(c:cs,u) | (c ,t) <- readLitChar s, - (cs,u) <- readl t ] -instance Show Char where - showsPrec p '\'' = showString "'\\''" - showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' - - showList cs = showChar '"' . showl cs - where showl "" = showChar '"' - showl ('"':cs) = showString "\\\"" . showl cs - showl (c:cs) = showLitChar c . showl cs - -type String = [Char] - ---------------------------------------------------------------- --- Maybe type - -data Maybe a = Nothing | Just a deriving (Eq, Ord, Read, Show) - -maybe :: b -> (a -> b) -> Maybe a -> b -maybe n f Nothing = n -maybe n f (Just x) = f x - -instance Functor Maybe where - map f Nothing = Nothing - map f (Just a) = Just (f a) - -instance Monad Maybe where - (Just x) >>= k = k x - Nothing >>= k = Nothing - return = Just - -instance MonadZero Maybe where - zero = Nothing - -instance MonadPlus Maybe where - Nothing ++ ys = ys - xs ++ ys = xs - ---------------------------------------------------------------- --- Either type - -data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show) - -either :: (a -> c) -> (b -> c) -> Either a b -> c -either f g (Left x) = f x -either f g (Right y) = g y - ---------------------------------------------------------------- --- IO type: moved to GHCbase - ---partain: data IO a = -- abstract - ---------------------------------------------------------------- --- Ordering type - -data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Read, Show, Bounded) - ---------------------------------------------------------------- --- Standard numeric types. The data declarations for these types --- cannot be expressed directly in (standard) Haskell since the --- constructor lists would be far too large. - ---------------------------------------------------------------- -data Int = I# Int# deriving (Eq,Ord) ---partain:data Int = minBound ... -1 | 0 | 1 ... maxBound - -instance CCallable Int -instance CReturnable Int - -instance Bounded Int where - minBound = negate 2147483647 -- ********************** - maxBound = 2147483647 -- ********************** - -instance Num Int where - (+) x y = plusInt x y - (-) x y = minusInt x y - negate x = negateInt x - (*) x y = timesInt x y - 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 (J# a# s# d#) - = case (integer2Int# a# s# d#) of { i# -> I# i# } - - fromInt n = n - -instance Real Int where - toRational x = toInteger x % 1 - -instance Integral Int where - a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b) - -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) - - -- following chks for zero divisor are non-standard (WDP) - a `quot` b = if b /= 0 - then a `quotInt` b - else error "Integral.Int.quot{PreludeCore}: divide by 0\n" - a `rem` b = if b /= 0 - then a `remInt` b - else error "Integral.Int.rem{PreludeCore}: divide by 0\n" - - x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y - else if x < 0 && y > 0 then quotInt (x-y+1) y - else quotInt x y - x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then - if r/=0 then r+y else 0 - else - r - where r = remInt x y - - divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y) - -- Stricter. Sorry if you don't like it. (WDP 94/10) - ---OLD: even x = eqInt (x `mod` 2) 0 ---OLD: odd x = neInt (x `mod` 2) 0 - - toInteger (I# n#) = int2Integer# n# -- give back a full-blown Integer - toInt x = x - -instance Enum Int where - toEnum x = x - fromEnum x = x -#ifndef USE_FOLDR_BUILD - enumFrom x = x : enumFrom (x `plusInt` 1) - enumFromTo n m = takeWhile (<= m) (enumFrom n) -#else - {-# INLINE enumFrom #-} - {-# INLINE enumFromTo #-} - enumFrom x = build (\ c _ -> - let g x = x `c` g (x `plusInt` 1) in g x) - enumFromTo x y = build (\ c n -> - let g x = if x <= y then x `c` g (x `plusInt` 1) else n in g x) -#endif - enumFromThen m n = en' m (n `minusInt` m) - where en' m n = m : en' (m `plusInt` n) n - enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) - (enumFromThen n m) - -instance Read Int where - readsPrec p x = readSigned readDec x - readList = readList__ (readsPrec 0) - -instance Show Int where - showsPrec x = showSigned showInt x - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- -data Integer = J# Int# Int# ByteArray# ---partain:data Integer = ... -1 | 0 | 1 ... - -instance Eq Integer where - (J# a1 s1 d1) == (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0# - - (J# a1 s1 d1) /= (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0# - -instance Ord Integer where - (J# a1 s1 d1) <= (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0# - - (J# a1 s1 d1) < (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) <# 0# - - (J# a1 s1 d1) >= (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0# - - (J# a1 s1 d1) > (J# a2 s2 d2) - = (cmpInteger# a1 s1 d1 a2 s2 d2) ># 0# - - x@(J# a1 s1 d1) `max` y@(J# a2 s2 d2) - = if ((cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#) then x else y - - x@(J# a1 s1 d1) `min` y@(J# a2 s2 d2) - = if ((cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#) then x else y - - compare (J# a1 s1 d1) (J# a2 s2 d2) - = case cmpInteger# a1 s1 d1 a2 s2 d2 of { res# -> - if res# <# 0# then LT else - if res# ># 0# then GT else EQ - } - -instance Num Integer where - (+) (J# a1 s1 d1) (J# a2 s2 d2) - = plusInteger# a1 s1 d1 a2 s2 d2 - - (-) (J# a1 s1 d1) (J# a2 s2 d2) - = minusInteger# a1 s1 d1 a2 s2 d2 - - negate (J# a s d) = negateInteger# a s d - - (*) (J# a1 s1 d1) (J# a2 s2 d2) - = timesInteger# a1 s1 d1 a2 s2 d2 - - -- ORIG: abs n = if n >= 0 then n else -n - - abs n@(J# a1 s1 d1) - = case 0 of { J# a2 s2 d2 -> - if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0# - then n - else negateInteger# a1 s1 d1 - } - - signum n@(J# a1 s1 d1) - = case 0 of { J# a2 s2 d2 -> - let - cmp = cmpInteger# a1 s1 d1 a2 s2 d2 - in - if cmp ># 0# then 1 - else if cmp ==# 0# then 0 - else (negate 1) - } - - fromInteger x = x - - fromInt (I# n#) = int2Integer# n# -- gives back a full-blown Integer - -instance Real Integer where - toRational x = x % 1 - -instance Integral Integer where - quotRem (J# a1 s1 d1) (J# a2 s2 d2) - = case (quotRemInteger# a1 s1 d1 a2 s2 d2) of - Return2GMPs a3 s3 d3 a4 s4 d4 - -> (J# a3 s3 d3, J# a4 s4 d4) - -{- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW: - - divMod (J# a1 s1 d1) (J# a2 s2 d2) - = case (divModInteger# a1 s1 d1 a2 s2 d2) of - Return2GMPs a3 s3 d3 a4 s4 d4 - -> (J# a3 s3 d3, J# a4 s4 d4) --} - toInteger n = n - toInt (J# a s d) = case (integer2Int# a s d) of { n# -> I# n# } - - -- the rest are identical to the report default methods; - -- you get slightly better code if you let the compiler - -- see them right here: - n `quot` d = q where (q,r) = quotRem n d - n `rem` d = r where (q,r) = quotRem n d - n `div` d = q where (q,r) = divMod n d - n `mod` d = r where (q,r) = divMod n d - - divMod n d = case (quotRem n d) of { qr@(q,r) -> - if signum r == negate (signum d) then (q - 1, r+d) else qr } - -- Case-ified by WDP 94/10 - -instance Enum Integer where - enumFrom n = n : enumFrom (n + 1) - enumFromThen m n = en' m (n - m) - where en' m n = m : en' (m + n) n - enumFromTo n m = takeWhile (<= m) (enumFrom n) - enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) - (enumFromThen n m) - -instance Read Integer where - readsPrec p x = readSigned readDec x - readList = readList__ (readsPrec 0) - -instance Show Integer where - showsPrec x = showSigned showInt x - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- -data Float = F# Float# deriving (Eq, Ord) -instance CCallable Float -instance CReturnable Float - ---------------------------------------------------------------- - -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 - fromInteger n = encodeFloat n 0 - fromInt i = int2Float i - -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 = fromRational__ x - recip x = 1.0 / x - -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 RealFrac Float where - - {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} - {-# SPECIALIZE truncate :: Float -> Int #-} - {-# 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 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 - ReturnIntAndGMP exp# a# s# d# -> - (J# a# s# d#, I# exp#) - - encodeFloat (J# a# s# d#) (I# e#) - = case encodeFloat# a# s# d# e# of { flt# -> F# flt# } - - 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) - -instance Read Float where - readsPrec p x = readSigned readFloat x - readList = readList__ (readsPrec 0) - -instance Show Float where - showsPrec x = showSigned showFloat x - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- -data Double = D# Double# deriving (Eq, Ord) -instance CCallable Double -instance CReturnable Double - ---------------------------------------------------------------- - -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 - fromInteger n = encodeFloat n 0 - fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# } - -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 = fromRational__ 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)) - -instance RealFrac Double where - - {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} - {-# SPECIALIZE truncate :: Double -> Int #-} - {-# 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 #-} - -#if defined(__UNBOXED_INSTANCES__) - {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-} - {-# SPECIALIZE truncate :: Double -> Int# #-} - {-# SPECIALIZE round :: Double -> Int# #-} - {-# SPECIALIZE ceiling :: Double -> Int# #-} - {-# SPECIALIZE floor :: Double -> Int# #-} -#endif - - 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# d#) - = case decodeDouble# d# of - ReturnIntAndGMP exp# a# s# d# -> - (J# a# s# d#, I# exp#) - - encodeFloat (J# a# s# d#) (I# e#) - = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# } - - 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) - -instance Read Double where - readsPrec p x = readSigned readFloat x - readList = readList__ (readsPrec 0) - -instance Show Double where - showsPrec x = showSigned showFloat x - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------- --- 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. - -instance Enum Float where - toEnum = fromIntegral - fromEnum = fromInteger . truncate -- may overflow - enumFrom = numericEnumFrom - enumFromThen = numericEnumFromThen - -instance Enum Double where - toEnum = fromIntegral - fromEnum = fromInteger . truncate -- may overflow - enumFrom = numericEnumFrom - enumFromThen = numericEnumFromThen - -numericEnumFrom :: (Real a) => a -> [a] -numericEnumFromThen :: (Real a) => a -> a -> [a] -numericEnumFrom = iterate (+1) -numericEnumFromThen n m = iterate (+(m-n)) n - ---------------------------------------------------------------- --- Lists - -data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) - -- to avoid weird names like con2tag_[]# - -instance CCallable [Char] -instance CReturnable [Char] - -instance (Eq a) => Eq [a] where - [] == [] = True - (x:xs) == (y:ys) = x == y && xs == ys - [] == ys = False - xs == [] = False - xs /= ys = if (xs == ys) then False else True - -instance (Ord a) => Ord [a] where - a < b = case compare a b of { LT -> True; EQ -> False; GT -> False } - a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False } - a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True } - a > b = case compare a b of { LT -> False; EQ -> False; GT -> True } - - max a b = case compare a b of { LT -> b; EQ -> a; GT -> a } - min a b = case compare a b of { LT -> a; EQ -> a; GT -> b } - - compare [] [] = EQ - compare (x:xs) [] = GT - compare [] (y:ys) = LT - compare (x:xs) (y:ys) = case compare x y of - LT -> LT - GT -> GT - EQ -> compare xs ys - -instance Functor [] where - map f [] = [] - map f (x:xs) = f x : map f xs - -instance Monad [] where - m >>= k = concat (map k m) - return x = [x] - -instance MonadZero [] where - zero = [] - -instance MonadPlus [] where - xs ++ ys = foldr (:) ys xs - -instance (Show a) => Show [a] where - showsPrec p = showList - showList = showList__ (showsPrec 0) - -instance (Read a) => Read [a] where - readsPrec p = readList - readList = readList__ (readsPrec 0) - ---------------------------------------------------------------- --- Tuples - -data (,) a b = (,) a b deriving (Eq, Ord, Bounded) -data (,,) a b c = (,,) a b c deriving (Eq, Ord, Bounded) -data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord, Bounded) -data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord, Bounded) -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_ - -- if you add more tuples, you need to change the compiler, too - -- (it has a wired-in number: 37) - -instance (Read a, Read b) => Read (a,b) where - readsPrec p = readParen False - (\r -> [((x,y), w) | ("(",s) <- lex r, - (x,t) <- reads s, - (",",u) <- lex t, - (y,v) <- reads u, - (")",w) <- lex v ] ) - readList = readList__ (readsPrec 0) - -instance (Read a, Read b, Read c) => Read (a, b, c) where - readsPrec p = readParen False - (\a -> [((x,y,z), h) | ("(",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 ] ) - readList = readList__ (readsPrec 0) - -instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where - readsPrec p = readParen False - (\a -> [((w,x,y,z), j) | ("(",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,i) <- readsPrec 0 h, - (")",j) <- lex i ] ) - readList = readList__ (readsPrec 0) - -instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where - readsPrec p = readParen False - (\a -> [((w,x,y,z,v), l) | ("(",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,i) <- readsPrec 0 h, - (",",j) <- lex i, - (v,k) <- readsPrec 0 j, - (")",l) <- lex k ] ) - readList = readList__ (readsPrec 0) - -instance (Show a, Show b) => Show (a,b) where - showsPrec p (x,y) = showChar '(' . shows x . showString ", " . - shows y . showChar ')' - showList = showList__ (showsPrec 0) - -instance (Show a, Show b, Show c) => Show (a, b, c) where - showsPrec p (x,y,z) = showChar '(' . showsPrec 0 x . showString ", " . - showsPrec 0 y . showString ", " . - showsPrec 0 z . showChar ')' - showList = showList__ (showsPrec 0) - -instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where - showsPrec p (w,x,y,z) = showChar '(' . showsPrec 0 w . showString ", " . - showsPrec 0 x . showString ", " . - showsPrec 0 y . showString ", " . - showsPrec 0 z . showChar ')' - - showList = showList__ (showsPrec 0) - -instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where - showsPrec p (v,w,x,y,z) = showChar '(' . showsPrec 0 v . showString ", " . - showsPrec 0 w . showString ", " . - showsPrec 0 x . showString ", " . - showsPrec 0 y . showString ", " . - showsPrec 0 z . showChar ')' - showList = showList__ (showsPrec 0) - ---------------------------------------------------------------------- --- component projections for pairs: --- (NB: not provided for triples, quadruples, etc.) -fst :: (a,b) -> a -fst (x,y) = x - -snd :: (a,b) -> b -snd (x,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) - --- Functions - --- Standard value bindings - --- identity function -id :: a -> a -id x = x - --- constant function -const :: a -> b -> a -const x _ = x - --- function composition -{-# INLINE (.) #-} -{-# GENERATE_SPECS (.) a b c #-} -(.) :: (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) -($) :: (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 - --- error stops execution and displays an error message - -error :: String -> a -error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) 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" - --- ============================================================ --- Standard list functions --- ============================================================ - -{- module PreludeList -} - --- 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 [] = error "PreludeList.head: empty list" - -last :: [a] -> a -last [x] = x -last (_:xs) = last xs -last [] = error "PreludeList.last: empty list" - -tail :: [a] -> [a] -tail (_:xs) = xs -tail [] = error "PreludeList.tail: empty list" - -init :: [a] -> [a] -init [x] = [] -init (x:xs) = x : init xs -init [] = error "PreludeList.init: empty list" - -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 [] = 0 -length (_:l) = 1 + length l - --- List index (subscript) operator, 0-origin -(!!) :: [a] -> Int -> a -(x:_) !! 0 = x -(_:xs) !! n | n > 0 = xs !! (n-1) -(_:_) !! _ = error "PreludeList.!!: negative index" -[] !! _ = error "PreludeList.!!: index too large" - --- 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, ...] - -foldl :: (a -> b -> a) -> a -> [b] -> a -foldl f z [] = z -foldl f z (x:xs) = foldl f (f z x) xs - -foldl1 :: (a -> a -> a) -> [a] -> a -foldl1 f (x:xs) = foldl f x xs -foldl1 _ [] = error "PreludeList.foldl1: empty list" - -scanl :: (a -> b -> a) -> a -> [b] -> [a] -scanl f q xs = q : (case xs of - [] -> [] - x:xs -> scanl f (f q x) xs) - -scanl1 :: (a -> a -> a) -> [a] -> [a] -scanl1 f (x:xs) = scanl f x xs -scanl1 _ [] = error "PreludeList.scanl1: empty list" - --- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the --- above functions. - -foldr :: (a -> b -> b) -> b -> [a] -> b -foldr f z [] = z -foldr f z (x:xs) = f x (foldr f z xs) - -foldr1 :: (a -> a -> a) -> [a] -> a -foldr1 f [x] = x -foldr1 f (x:xs) = f x (foldr1 f xs) -foldr1 _ [] = error "PreludeList.foldr1: empty list" - -scanr :: (a -> b -> b) -> b -> [a] -> [b] -scanr f 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 f [x] = [x] -scanr1 f (x:xs) = f x q : qs - where qs@(q:_) = scanr1 f xs -scanr1 _ [] = error "PreludeList.scanr1: empty list" - --- iterate f x returns an infinite list of repeated applications of f to x: --- iterate f x == [x, f x, f (f x), ...] -iterate :: (a -> a) -> a -> [a] -iterate f x = x : iterate f (f x) - --- repeat x is an infinite list, with x the value of every element. -repeat :: a -> [a] -repeat x = xs where xs = x:xs - --- 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 xs = xs' where xs' = xs ++ 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). - -take :: Int -> [a] -> [a] -take 0 _ = [] -take _ [] = [] -take n (x:xs) | n > 0 = x : take (n-1) xs -take _ _ = error "PreludeList.take: negative argument" - -drop :: Int -> [a] -> [a] -drop 0 xs = xs -drop _ [] = [] -drop n (_:xs) | n > 0 = drop (n-1) xs -drop _ _ = error "PreludeList.drop: negative argument" - -splitAt :: Int -> [a] -> ([a],[a]) -splitAt 0 xs = ([],xs) -splitAt _ [] = ([],[]) -splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs -splitAt _ _ = error "PreludeList.splitAt: negative argument" - --- 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 p [] = [] -takeWhile p (x:xs) - | p x = x : takeWhile p xs - | otherwise = [] - -dropWhile :: (a -> Bool) -> [a] -> [a] -dropWhile p [] = [] -dropWhile p xs@(x:xs') - | p x = dropWhile p xs' - | otherwise = xs - -span, break :: (a -> Bool) -> [a] -> ([a],[a]) -span p [] = ([],[]) -span p xs@(x:xs') - | p x = let (ys,zs) = span p xs' in (x:ys,zs) - | otherwise = ([],xs) -break p = span (not . p) - --- 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. - -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 -unlines = concatMap (++ "\n") - -unwords :: [String] -> String -unwords [] = "" -unwords ws = foldr1 (\w s -> w ++ ' ':s) ws - --- reverse xs returns the elements of xs in reverse order. xs must be finite. -reverse :: [a] -> [a] -reverse = foldl (flip (:)) [] - --- 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 -and = foldr (&&) True -or = foldr (||) False - --- 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 -any p = or . map p -all p = and . map p - --- 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 -elem x = any (== x) -notElem x = all (not . (/= x)) - --- 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 - --- sum and product compute the sum or product of a finite list of numbers. -sum, product :: (Num a) => [a] -> a -sum = foldl (+) 0 -product = foldl (*) 1 - --- maximum and minimum return the maximum or minimum value from a list, --- which must be non-empty, finite, and of an ordered type. -maximum, minimum :: (Ord a) => [a] -> a -maximum [] = error "PreludeList.maximum: empty list" -maximum xs = foldl1 max xs - -minimum [] = error "PreludeList.minimum: empty list" -minimum xs = foldl1 min xs - -concatMap :: (a -> [b]) -> [a] -> [b] -concatMap f = concat . map f - --- 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 library - -zip :: [a] -> [b] -> [(a,b)] -zip = zipWith (,) - -zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] -zip3 = zipWith3 (,,) - --- 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. - -zipWith :: (a->b->c) -> [a]->[b]->[c] -zipWith z (a:as) (b:bs) = z a b : zipWith z as bs -zipWith _ _ _ = [] - -zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith3 z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3 z as bs cs -zipWith3 _ _ _ _ = [] - - --- unzip transforms a list of pairs into a pair of lists. - -unzip :: [(a,b)] -> ([a],[b]) -unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) - -unzip3 :: [(a,b,c)] -> ([a],[b],[c]) -unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) - ([],[],[]) - -{- module PreludeText -} - -type ReadS a = String -> [(a,String)] -type ShowS = String -> String - -class Read a where - readsPrec :: Int -> ReadS a - readList :: ReadS [a] - - readList = readParen False (\r -> [pr | ("[",s) <- lex r, - pr <- readl s]) - where readl s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,u) | (x,t) <- reads s, - (xs,u) <- readl' t] - readl' s = [([],t) | ("]",t) <- lex s] ++ - [(x:xs,v) | (",",t) <- lex s, - (x,u) <- reads t, - (xs,v) <- readl' u] - -class Show a where - showsPrec :: Int -> a -> ShowS - showList :: [a] -> ShowS - - showList [] = showString "[]" - showList (x:xs) - = showChar '[' . shows x . showl xs - where showl [] = showChar ']' - showl (x:xs) = showString ", " . shows x . showl xs - -reads :: (Read a) => ReadS a -reads = readsPrec 0 - -shows :: (Show a) => a -> ShowS -shows = showsPrec 0 - -read :: (Read a) => String -> a -read s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> x - [] -> error "PreludeText.read: no parse" - _ -> error "PreludeText.read: ambiguous parse" - -show :: (Show a) => a -> String -show x = shows x "" - -showChar :: Char -> ShowS -showChar = (:) - -showString :: String -> ShowS -showString = (++) - -showParen :: Bool -> ShowS -> ShowS -showParen b p = if b then showChar '(' . p . showChar ')' else p - -readParen :: Bool -> ReadS a -> ReadS a -readParen b g = if b then mandatory else optional - where optional r = g r ++ mandatory r - mandatory r = [(x,u) | ("(",s) <- lex r, - (x,t) <- optional s, - (")",u) <- lex t ] - --- lex: moved to GHCbase - -{- module PreludeIO -} - --- in GHCio: type FilePath = String - -fail :: IOError -> IO a -fail err = IO $ ST $ \ s -> (Left err, s) - -userError :: String -> IOError -userError str = UserError str - -catch :: IO a -> (IOError -> IO a) -> IO a -catch (IO (ST m)) k = IO $ ST $ \ s -> - case (m s) of { (r, new_s) -> - case r of - Right _ -> (r, new_s) - Left err -> case (k err) of { IO (ST k_err) -> - (k_err new_s) }} - -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 = do c <- getChar - if c == '\n' then return "" else - do s <- getLine - return (c:s) - -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 - = openFile name WriteMode >>= \hdl -> hPutStr hdl str >> hClose hdl - -appendFile :: FilePath -> String -> IO () -appendFile name str - = openFile name AppendMode >>= \hdl -> hPutStr hdl str >> hClose hdl - -readIO :: Read a => String -> IO a - -- raises an exception instead of an error -readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of - [x] -> return x - [] -> fail (userError "PreludeIO.readIO: no parse") - _ -> fail (userError - "PreludeIO.readIO: ambiguous parse") - -readLn :: Read a => IO a -readLn = do l <- getLine - r <- readIO l - return r diff --git a/ghc/lib/prelude/PreludeGlaST.hs b/ghc/lib/prelude/PreludeGlaST.hs deleted file mode 100644 index 179b648..0000000 --- a/ghc/lib/prelude/PreludeGlaST.hs +++ /dev/null @@ -1,94 +0,0 @@ --- solely for backward-compatibility with pre-2.00 GHC systems. - -module PreludeGlaST ( - Array(..), -- NB: makes internals visible - MutableVar, - ST, - ByteArray, - MutableArray, - MutableByteArray, - PrimIO, - Addr(..), Word(..), - CCallable(..), CReturnable(..), - - boundsOfArray, - boundsOfByteArray, - fixPrimIO, - fixST, - forkPrimIO, - forkST, - freezeAddrArray, - freezeArray, - freezeCharArray, - freezeDoubleArray, - freezeFloatArray, - freezeIntArray, - indexAddrArray, - indexAddrOffAddr, - indexCharArray, - indexCharOffAddr, - indexDoubleArray, - indexDoubleOffAddr, - indexFloatArray, - indexFloatOffAddr, - indexIntArray, - indexIntOffAddr, - ioToST, - listPrimIO, - listST, - mapAndUnzipPrimIO, - mapAndUnzipST, - mapPrimIO, - mapST, - newAddrArray, - newArray, - newCharArray, - newDoubleArray, - newFloatArray, - newIntArray, - newVar, - readAddrArray, - readArray, - readCharArray, - readDoubleArray, - readFloatArray, - readIntArray, - readVar, - returnPrimIO, - returnST, - returnStrictlyST, - runST, - primIOToIO, - ioToPrimIO, - sameMutableArray, - sameMutableByteArray, - sameVar, - seqPrimIO, - seqST, - seqStrictlyST, - stToIO, - thawArray, - thenPrimIO, - thenST, - thenStrictlyST, - unsafeFreezeArray, - unsafeFreezeByteArray, - unsafeInterleavePrimIO, - unsafeInterleaveST, - unsafePerformPrimIO, - writeAddrArray, - writeArray, - writeCharArray, - writeDoubleArray, - writeFloatArray, - writeIntArray, - writeVar -#ifndef __PARALLEL_HASKELL__ - , makeStablePtr - , deRefStablePtr - , freeStablePtr - , performGC -#endif - ) where - -import GHCbase