Adding in the modified versions of the Standard Haskell 98 libraries.
These should compile under both Hugs and GHC.
use the flags -D__HUGS__ -DUSE_REPORT_PRELUDE to extract the Hugs src.
) where
+#ifndef __HUGS__
import Ix
import PrelList
import PrelShow
import PrelArr -- Most of the hard work is done here
import PrelBase
+#else
+import Ix
+import List( (\\) )
+#endif
infixl 9 !, //
\end{code}
+#ifndef __HUGS__
%*********************************************************
readList = readList__ (readsPrec 0)
-}
\end{code}
+
+
+#else
+\begin{code}
+data Array ix elt = Array (ix,ix) (PrimArray elt)
+
+array :: Ix a => (a,a) -> [(a,b)] -> Array a b
+array ixs@(ix_start, ix_end) ivs = primRunST (do
+ { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom
+ ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs
+ ; arr <- primUnsafeFreezeArray mut_arr
+ ; return (Array ixs arr)
+ }
+ )
+ where
+ arrEleBottom = error "(Array.!): undefined array element"
+
+listArray :: Ix a => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: Ix a => Array a b -> a -> b
+(Array bounds arr) ! i = primIndexArray arr (index bounds i)
+
+bounds :: Ix a => Array a b -> (a,a)
+bounds (Array b _) = b
+
+indices :: Ix a => Array a b -> [a]
+indices = range . bounds
+
+elems :: Ix a => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: Ix a => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: Ix a => Array a b -> [(a,b)] -> Array a b
+a // us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+
+instance (Ix a) => Functor (Array a) where
+ fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a]
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ a <= a' = assocs a <= assocs a'
+
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+
+\end{code}
+#endif
getCPUTime, -- :: IO Integer
cpuTimePrecision -- :: Integer
) where
+\end{code}
-#ifdef __HUGS__
-import PreludeBuiltin
-#else
+
+#ifndef __HUGS__
+\begin{code}
import PrelBase
import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray )
import PrelMaybe
import PrelNumExtra
import PrelIOBase
import PrelST
-#endif
import IO ( ioError )
import PrelNum ( Num(..), Integral(..) ) -- To get fromInt/toInt
import Ratio
-
\end{code}
Computation @getCPUTime@ returns the number of picoseconds CPU time
\end{code}
+#else
+
+\begin{code}
+-- TODO: Hugs/getCPUTime
+getCPUTime :: IO Integer
+getCPUTime = return 0
-
+-- TODO: Hugs/cpuTimePrecision
+cpuTimePrecision :: Integer
+cpuTimePrecision = 1
+\end{code}
+#endif
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+#ifndef __HUGS__
import PrelBase
import PrelShow
import PrelEnum
import PrelNum
import PrelRead (readLitChar, lexLitChar, digitToInt)
import PrelErr ( error )
+#else
+isLatin1 c = True
+#endif
\end{code}
) where
#ifdef __HUGS__
-import PreludeBuiltin
+--import PreludeBuiltin
#else
import PrelBase
import PrelIOBase
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#ifndef BODY /* Hugs just includes this in PreludeBuiltin so no header needed */
module IO (
Handle, -- abstract, instance of: Eq, Show.
HandlePosn(..), -- abstract, instance of: Eq, Show.
readIO, -- :: Read a => String -> IO a
readLn, -- :: Read a => IO a
+#ifndef __HUGS__
-- extensions
hPutBuf,
-#ifndef __HUGS__
hPutBufBA,
#endif
slurpFile
) where
#ifdef __HUGS__
-
-import PreludeBuiltin
-
+import Ix(Ix)
#else
-
--import PrelST
import PrelBase
import Char ( ord, chr )
#endif /* ndef __HUGS__ */
-#endif /* ndef BODY */
-
-#ifndef HEAD
-
-#ifdef __HUGS__
-#define __CONCURRENT_HASKELL__
-#define stToIO id
-#define unpackNBytesAccST primUnpackCStringAcc
-#endif
-
\end{code}
+#ifndef __HUGS__
+
Standard instances for @Handle@:
\begin{code}
r <- readIO l
return r
-#endif /* ndef HEAD */
\end{code}
+
+#else
+\begin{code}
+unimp :: String -> a
+unimp s = error ("function not implemented: " ++ s)
+
+type FILE_STAR = Int
+type Ptr = Int
+nULL = 0 :: Int
+
+data Handle
+ = Handle { name :: FilePath,
+ file :: FILE_STAR, -- C handle
+ state :: HState, -- open/closed/semiclosed
+ mode :: IOMode,
+ --seekable :: Bool,
+ bmode :: BufferMode,
+ buff :: Ptr,
+ buffSize :: Int
+ }
+
+instance Eq Handle where
+ h1 == h2 = file h1 == file h2
+
+instance Show Handle where
+ showsPrec _ h = showString ("<<handle " ++ name h ++ "=" ++ show (file h) ++ ">>")
+
+data HandlePosn
+ = HandlePosn
+ deriving (Eq, Show)
+
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
+
+data BufferMode = NoBuffering | LineBuffering
+ | BlockBuffering
+ deriving (Eq, Ord, Read, Show)
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
+
+data HState = HOpen | HSemiClosed | HClosed
+ deriving Eq
+
+stdin = Handle "stdin" (primRunST nh_stdin) HOpen ReadMode NoBuffering nULL 0
+stdout = Handle "stdout" (primRunST nh_stdout) HOpen WriteMode LineBuffering nULL 0
+stderr = Handle "stderr" (primRunST nh_stderr) HOpen WriteMode NoBuffering nULL 0
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile f mode
+ = copy_String_to_cstring f >>= \nameptr ->
+ nh_open nameptr (mode2num mode) >>= \fh ->
+ nh_free nameptr >>
+ if fh == nULL
+ then (ioError.IOError) ("openFile: can't open " ++ f ++ " in " ++ show mode)
+ else return (Handle f fh HOpen mode BlockBuffering nULL 0)
+ where
+ mode2num :: IOMode -> Int
+ mode2num ReadMode = 0
+ mode2num WriteMode = 1
+ mode2num AppendMode = 2
+
+hClose :: Handle -> IO ()
+hClose h
+ | not (state h == HOpen)
+ = (ioError.IOError) ("hClose on non-open handle " ++ show h)
+ | otherwise
+ = nh_close (file h) >>
+ nh_errno >>= \err ->
+ if err == 0
+ then return ()
+ else (ioError.IOError) ("hClose: error closing " ++ name h)
+
+hFileSize :: Handle -> IO Integer
+hFileSize = unimp "IO.hFileSize"
+hIsEOF :: Handle -> IO Bool
+hIsEOF = unimp "IO.hIsEOF"
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+hSetBuffering :: Handle -> BufferMode -> IO ()
+hSetBuffering = unimp "IO.hSetBuffering"
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering = unimp "IO.hGetBuffering"
+
+hFlush :: Handle -> IO ()
+hFlush h
+ = if state h /= HOpen
+ then (ioError.IOError) ("hFlush on closed/semiclosed file " ++ name h)
+ else nh_flush (file h)
+
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn = unimp "IO.hGetPosn"
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn = unimp "IO.hSetPosn"
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek = unimp "IO.hSeek"
+hWaitForInput :: Handle -> Int -> IO Bool
+hWaitForInput = unimp "hWaitForInput"
+hReady :: Handle -> IO Bool
+hReady h = hWaitForInput h 0
+
+hGetChar :: Handle -> IO Char
+hGetChar h
+ = nh_read (file h) >>= \ci ->
+ return (primIntToChar ci)
+
+hGetLine :: Handle -> IO String
+hGetLine h = do c <- hGetChar h
+ if c=='\n' then return ""
+ else do cs <- hGetLine h
+ return (c:cs)
+
+hLookAhead :: Handle -> IO Char
+hLookAhead = unimp "IO.hLookAhead"
+
+hGetContents :: Handle -> IO String
+hGetContents h
+ | not (state h == HOpen && mode h == ReadMode)
+ = (ioError.IOError) ("hGetContents on invalid handle " ++ show h)
+ | otherwise
+ = read_all (file h)
+ where
+ read_all f
+ = unsafeInterleaveIO (
+ nh_read f >>= \ci ->
+ if ci == -1
+ then hClose h >> return []
+ else read_all f >>= \rest ->
+ return ((primIntToChar ci):rest)
+ )
+
+hPutStr :: Handle -> String -> IO ()
+hPutStr h s
+ | not (state h == HOpen && mode h /= ReadMode)
+ = (ioError.IOError) ("hPutStr on invalid handle " ++ show h)
+ | otherwise
+ = write_all (file h) s
+ where
+ write_all f []
+ = return ()
+ write_all f (c:cs)
+ = nh_write f (primCharToInt c) >>
+ write_all f cs
+
+hPutChar :: Handle -> Char -> IO ()
+hPutChar h c = hPutStr h [c]
+
+hPutStrLn :: Handle -> String -> IO ()
+hPutStrLn h s = do { hPutStr h s; hPutChar h '\n' }
+
+hPrint :: Show a => Handle -> a -> IO ()
+hPrint h = hPutStrLn h . show
+
+hIsOpen, hIsClosed, hIsReadable, hIsWritable :: Handle -> IO Bool
+hIsOpen h = return (state h == HOpen)
+hIsClosed h = return (state h == HClosed)
+hIsReadable h = return (mode h == ReadMode)
+hIsWritable h = return (mode h == WriteMode)
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable = unimp "IO.hIsSeekable"
+
+isIllegalOperation,
+ isAlreadyExistsError,
+ isDoesNotExistError,
+ isAlreadyInUseError,
+ isFullError,
+ isEOFError,
+ isPermissionError,
+ isUserError :: IOError -> Bool
+
+isIllegalOperation = unimp "IO.isIllegalOperation"
+isAlreadyExistsError = unimp "IO.isAlreadyExistsError"
+isDoesNotExistError = unimp "IO.isDoesNotExistError"
+isAlreadyInUseError = unimp "IO.isAlreadyInUseError"
+isFullError = unimp "IO.isFullError"
+isEOFError = unimp "IO.isEOFError"
+isPermissionError = unimp "IO.isPermissionError"
+isUserError = unimp "IO.isUserError"
+
+
+ioeGetErrorString :: IOError -> String
+ioeGetErrorString = unimp "ioeGetErrorString"
+ioeGetHandle :: IOError -> Maybe Handle
+ioeGetHandle = unimp "ioeGetHandle"
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetFileName = unimp "ioeGetFileName"
+
+try :: IO a -> IO (Either IOError a)
+try p = catch (p >>= (return . Right)) (return . Left)
+
+bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+ x <- before
+ rs <- try (m x)
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
+
+-- variant of the above where middle computation doesn't want x
+bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+ x <- before
+ rs <- try m
+ after x
+ case rs of
+ Right r -> return r
+ Left e -> ioError e
+
+-- TODO: Hugs/slurbFile
+slurpFile = unimp "slurpFile"
+\end{code}
+#endif
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+#ifndef __HUGS__
import {-# SOURCE #-} PrelErr ( error )
import PrelTup
import PrelBase
-- Here l<h, but the second index ranges from 2..1 and
-- hence is empty
\end{code}
+
+\begin{code}
+#else
+-- This module is empty; Ix is currently defined in the prelude, but should
+-- eventually be moved to this library file instead.
+#endif
+\end{code}
\begin{code}
module List
(
+#ifndef __HUGS__
[]((:), [])
+ ,
+#endif
- , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int
+ elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int
, elemIndices -- :: (Eq a) => a -> [a] -> [Int]
, find -- :: (a -> Bool) -> [a] -> Maybe a
) where
import Prelude
-import PrelShow ( lines, words, unlines, unwords )
import Maybe ( listToMaybe )
+
+#ifndef __HUGS__
+import PrelShow ( lines, words, unlines, unwords )
import PrelBase ( Int(..), map, (++) )
import PrelGHC ( (+#) )
+#endif
-infix 5 \\
+infix 5 \\
\end{code}
%*********************************************************
nub = nubBy (==)
#else
-- stolen from HBC
-nub l = nub' l []
+nub l = nub' l [] -- '
where
- nub' [] _ = []
- nub' (x:xs) ls
- | x `elem` ls = nub' xs ls
- | otherwise = x : nub' xs (x:ls)
+ nub' [] _ = [] -- '
+ nub' (x:xs) ls -- '
+ | x `elem` ls = nub' xs ls -- '
+ | otherwise = x : nub' xs (x:ls) -- '
#endif
nubBy :: (a -> a -> Bool) -> [a] -> [a]
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+#ifndef __HUGS__
import PrelErr ( error )
import PrelList
import PrelMaybe
import PrelBase
+#endif
\end{code}
, (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b
) where
+#ifndef __HUGS__
import PrelList
import PrelTup
import PrelBase
import PrelMaybe ( Maybe(..) )
infixr 1 =<<
+#endif
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
+#ifdef __HUGS__
+-- These functions are defined in the Prelude.
+-- sequence :: Monad m => [m a] -> m [a]
+-- sequence_ :: Monad m => [m a] -> m ()
+-- mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+-- mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+#else
sequence :: Monad m => [m a] -> m [a]
sequence [] = return []
sequence (m:ms) = do { x <- m; xs <- sequence ms; return (x:xs) }
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
{-# INLINE mapM_ #-}
mapM_ f as = sequence_ (map f as)
+#endif
guard :: MonadPlus m => Bool -> m ()
guard pred
{-# INLINE msum #-}
msum = foldr mplus mzero
+#ifdef __HUGS__
+-- This function is defined in the Prelude.
+--(=<<) :: Monad m => (a -> m b) -> m a -> m b
+#else
{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-}
(=<<) :: Monad m => (a -> m b) -> m a -> m b
f =<< x = x >>= f
+#endif
\end{code}
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
+#ifndef __HUGS__
import PrelBase
import PrelMaybe
import PrelShow
import PrelNumExtra
import PrelRead
import PrelErr ( error )
-
+#else
+import Char
+import Array
+#endif
\end{code}
+#ifndef __HUGS__
+
\begin{code}
showInt :: Integral a => a -> ShowS
showInt i rs
showGFloat d x = showString (formatRealFloat FFGeneric d x)
\end{code}
+
+#else
+\begin{code}
+-- This converts a rational to a floating. This should be used in the
+-- Fractional instances of Float and Double.
+
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x =
+ if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
+ else if x < 0 then - fromRat' (-x) -- first.
+ else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+ where b = floatRadix r
+ p = floatDigits r
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) -
+ integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational ->
+ Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x =
+ if p <= minExp then
+ (x, p)
+ else if x >= xMax then
+ scaleRat b minExp xMin xMax (p+1) (x/b)
+ else if x < xMin then
+ scaleRat b minExp xMin xMax (p-1) (x*b)
+ else
+ (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts!n
+ else
+ base^n
+
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b,
+-- but that would be very slow! We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i =
+ if i < b then
+ 0
+ else
+ -- Try squaring the base first to cut down the number of divisions.
+ let l = 2 * integerLogBase (b*b) i
+ doDiv :: Integer -> Int -> Int
+ doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+ in doDiv (i `div` (b^l)) l
+
+
+-- Misc utilities to show integers and floats
+
+showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat :: (RealFloat a) => a -> ShowS
+
+showEFloat d x = showString (formatRealFloat FFExponent d x)
+showFFloat d x = showString (formatRealFloat FFFixed d x)
+showGFloat d x = showString (formatRealFloat FFGeneric d x)
+showFloat = showGFloat Nothing
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where base = 10
+ s = if isNaN x then
+ "NaN"
+ else if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else if x < 0 || isNegativeZero x then
+ '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is
+ in case fmt of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is, e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ case ds of
+ ['0'] -> "0.0e0"
+ [d] -> d : ".0e" ++ show (e-1)
+ d:ds -> d : '.' : ds ++ 'e':show (e-1)
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let (ei, is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit
+ (if ei > 0 then init is' else is')
+ in d:'.':ds ++ "e" ++ show (e-1+ei)
+ FFFixed ->
+ case decs of
+ Nothing ->
+ let f 0 s ds = mk0 s ++ "." ++ mk0 ds
+ f n s "" = f (n-1) (s++"0") ""
+ f n s (d:ds) = f (n-1) (s++[d]) ds
+ mk0 "" = "0"
+ mk0 s = s
+ in f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let (ei, is') = roundTo base (dec' + e) is
+ (ls, rs) = splitAt (e+ei) (map intToDigit is')
+ in (if null ls then "0" else ls) ++
+ (if null rs then "" else '.' : rs)
+ else
+ let (ei, is') = roundTo base dec'
+ (replicate (-e) 0 ++ is)
+ d : ds = map intToDigit
+ (if ei > 0 then is' else 0:is')
+ in d : '.' : ds
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+ (0, is) -> (0, is)
+ (1, is) -> (1, 1 : is)
+ where b2 = base `div` 2
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+ f d (i:is) =
+ let (c, ds) = f (d-1) is
+ i' = c + i
+ in if i' == base then (1, 0:ds) else (0, i':ds)
+
+--
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) = let n = minExp - e0
+ in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let k0 =
+ if b==2 && base==10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ log (fromInteger base))
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n
+ else fixup (n+1)
+ in fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k)
+ in gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in (map toInt (reverse rds), k)
+\end{code}
+#endif
, newStdGen
) where
+#ifndef __HUGS__
import CPUTime (getCPUTime)
import PrelST
import PrelRead
import PrelNumExtra ( float2Double, double2Float )
import PrelBase
import PrelArr
-import Char ( isSpace, chr, ord )
import Time (getClockTime, ClockTime(..))
-
+#else
+#endif
+import Char ( isSpace, chr, ord )
\end{code}
\begin{code}
next = stdNext
split = stdSplit
+#ifdef __HUGS__
+instance Show StdGen where
+ showsPrec p (StdGen s1 s2) =
+ showsPrec p s1 .
+ showChar ' ' .
+ showsPrec p s2
+#else
instance Show StdGen where
showsPrec p (StdGen s1 s2) =
showSignedInt p s1 .
showSpace .
showSignedInt p s2
+#endif
instance Read StdGen where
readsPrec _p = \ r ->
random g = randomR (0::Double,1) g
-- hah, so you thought you were saving cycles by using Float?
+
+#ifdef __HUGS__
+instance Random Float where
+ random g = randomIvalDouble (0::Double,1) realToFrac g
+ randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
+#else
instance Random Float where
randomR (a,b) g = randomIvalDouble (float2Double a, float2Double b) double2Float g
random g = randomIvalDouble (0::Double,1) double2Float g
+#endif
\end{code}
\begin{code}
+#ifdef __HUGS__
+mkStdRNG :: Integer -> IO StdGen
+mkStdRNG o = return (createStdGen o)
+#else
mkStdRNG :: Integer -> IO StdGen
mkStdRNG o = do
ct <- getCPUTime
(TOD sec _) <- getClockTime
return (createStdGen (sec * 12345 + ct + o))
+#endif
randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l,h) rng
s2' = 40692 * (s2 - k' * 52774) - k' * 3791
s2'' = if s2' < 0 then s2' + 2147483399 else s2'
+#ifdef __HUGS__
+stdSplit :: StdGen -> (StdGen, StdGen)
+stdSplit std@(StdGen s1 s2)
+ = (left, right)
+ where
+ -- no statistical foundation for this!
+ left = StdGen new_s1 t2
+ right = StdGen t1 new_s2
+
+ new_s1 | s1 == 2147483562 = 1
+ | otherwise = s1 + 1
+
+ new_s2 | s2 == 1 = 2147483398
+ | otherwise = s2 - 1
+
+ StdGen t1 t2 = snd (next std)
+#else
stdSplit :: StdGen -> (StdGen, StdGen)
stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))
-
+#endif
\end{code}
\begin{code}
+#ifdef __HUGS__
+-- TODO: Hugs/setStdGen
+setStdGen :: StdGen -> IO ()
+setStdGen sgen = error "not currently implemented in Stg Hugs"
+
+-- TODO: Hugs/getStdGen
+getStdGen :: IO StdGen
+getStdGen = error "not currently implemented in Stg Hugs"
+#else
global_rng :: MutableVar RealWorld StdGen
global_rng = unsafePerformIO $ do
rng <- mkStdRNG 0
getStdGen :: IO StdGen
getStdGen = stToIO (readVar global_rng)
+#endif
+
newStdGen :: IO StdGen
newStdGen = do
) where
+#ifndef __HUGS__
import PrelNum
import PrelNumExtra
+#endif
\end{code}
, exitWith -- :: ExitCode -> IO a
, exitFailure -- :: IO a
) where
+\end{code}
-#ifdef __HUGS__
-import PreludeBuiltin
-
-indexAddrOffAddr = primIndexAddrOffAddr
-
-unpackCString = unsafeUnpackCString
-#else
+#ifndef __HUGS__
+\begin{code}
import Prelude
import PrelAddr
import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO )
primPackString :: String -> PrimByteArray
primPackString s = packString s
-#endif
\end{code}
de_slash _acc ('/':xs) = de_slash [] xs
de_slash acc (x:xs) = de_slash (x:acc) xs
\end{code}
+
+#else
+
+\begin{code}
+-----------------------------------------------------------------------------
+-- Standard Library: System operations
+--
+-- Warning: the implementation of these functions in Hugs 98 is very weak.
+-- The functions themselves are best suited to uses in compiled programs,
+-- and not to use in an interpreter-based environment like Hugs.
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+data ExitCode = ExitSuccess | ExitFailure Int
+ deriving (Eq, Ord, Read, Show)
+
+getArgs :: IO [String]
+getArgs = primGetRawArgs >>= \rawargs ->
+ return (drop 1 (dropWhile (/= "--") rawargs))
+
+getProgName :: IO String
+getProgName = primGetRawArgs >>= \rawargs ->
+ return (head rawargs)
+
+getEnv :: String -> IO String
+getEnv = primGetEnv
+
+system :: String -> IO ExitCode
+system s = error "System.system unimplemented"
+
+exitWith :: ExitCode -> IO a
+exitWith c = error "System.exitWith unimplemented"
+
+exitFailure :: IO a
+exitFailure = exitWith (ExitFailure 1)
+
+toExitCode :: Int -> ExitCode
+toExitCode 0 = ExitSuccess
+toExitCode n = ExitFailure n
+
+fromExitCode :: ExitCode -> Int
+fromExitCode ExitSuccess = 0
+fromExitCode (ExitFailure n) = n
+
+-----------------------------------------------------------------------------
+\end{code}
+#endif
projects / ghc-hetmet.git / commitdiff