+++ /dev/null
-{- 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 "<<IO action>>"
- 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
+++ /dev/null
-{- 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 /= '|'
+++ /dev/null
-{-
-%
-% (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"
- )
+++ /dev/null
--- 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.)
--}
+++ /dev/null
-{-
-%
-% (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#) }
+++ /dev/null
-interface Main 1
-__exports__
-Main main (..)
-__declarations__
-Main.main :: GHCbase.IO Prelude.();
+++ /dev/null
-interface Main 1
-__exports__
-Main main (..)
-__declarations__
-Main.main :: GHCbase.IO Prelude.();
+++ /dev/null
-interface Main 1
-__exports__
-Main main (..)
-__declarations__
-Main.main :: GHCbase.IO Prelude.();
+++ /dev/null
-interface Main 1
-__exports__
-Main main (..)
-__declarations__
-Main.main :: GHCbase.IO Prelude.();
+++ /dev/null
-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 "<<function>>"
- 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
+++ /dev/null
--- 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
projects / ghc-hetmet.git / commitdiff