Commit f608faec authored by andy's avatar andy
Browse files

[project @ 1999-10-29 01:16:48 by andy]

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.
parent 290d2574
......@@ -38,15 +38,21 @@ module Array
) 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__
%*********************************************************
......@@ -122,3 +128,77 @@ instance (Ix a, Read a, Read b) => Read (Array a b) where
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
......@@ -11,10 +11,11 @@ module CPUTime
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
......@@ -22,11 +23,9 @@ import PrelNum
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
......@@ -91,5 +90,15 @@ foreign import "libHS_cbits" "clockTicks" clockTicks :: IO Int
\end{code}
#else
\begin{code}
-- TODO: Hugs/getCPUTime
getCPUTime :: IO Integer
getCPUTime = return 0
-- TODO: Hugs/cpuTimePrecision
cpuTimePrecision :: Integer
cpuTimePrecision = 1
\end{code}
#endif
......@@ -32,10 +32,14 @@ module Char
-- 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}
......@@ -51,7 +51,7 @@ module Directory
) where
#ifdef __HUGS__
import PreludeBuiltin
--import PreludeBuiltin
#else
import PrelBase
import PrelIOBase
......
......@@ -10,7 +10,6 @@ definition.
\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.
......@@ -84,9 +83,9 @@ module IO (
readIO, -- :: Read a => String -> IO a
readLn, -- :: Read a => IO a
#ifndef __HUGS__
-- extensions
hPutBuf,
#ifndef __HUGS__
hPutBufBA,
#endif
slurpFile
......@@ -94,11 +93,8 @@ module IO (
) where
#ifdef __HUGS__
import PreludeBuiltin
import Ix(Ix)
#else
--import PrelST
import PrelBase
......@@ -122,18 +118,10 @@ import PrelForeign ( ForeignObj )
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}
......@@ -745,6 +733,221 @@ readLn = do l <- getLine
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
......@@ -29,6 +29,7 @@ module Ix
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
#ifndef __HUGS__
import {-# SOURCE #-} PrelErr ( error )
import PrelTup
import PrelBase
......@@ -267,3 +268,10 @@ rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1
-- 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}
......@@ -7,9 +7,12 @@
\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
......@@ -127,12 +130,15 @@ module List
) 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}
%*********************************************************
......@@ -181,12 +187,12 @@ nub :: (Eq a) => [a] -> [a]
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]
......
......@@ -29,10 +29,12 @@ module Maybe
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
#ifndef __HUGS__
import PrelErr ( error )
import PrelList
import PrelMaybe
import PrelBase
#endif
\end{code}
......
......@@ -39,12 +39,14 @@ module Monad
, (=<<) -- :: (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}
%*********************************************************
......@@ -78,6 +80,13 @@ instance MonadPlus Maybe where
%*********************************************************
\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) }
......@@ -93,6 +102,7 @@ mapM f as = sequence (map f as)
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
......@@ -114,9 +124,14 @@ msum :: MonadPlus m => [m a] -> m a
{-# 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}
......
......@@ -34,6 +34,7 @@ module Numeric
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
#ifndef __HUGS__
import PrelBase
import PrelMaybe
import PrelShow
......@@ -42,9 +43,14 @@ import PrelNum
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
......@@ -75,3 +81,233 @@ showFFloat d x = showString (formatRealFloat FFFixed d x)
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