Commit 0d65c162 authored by sof's avatar sof
Browse files

[project @ 1999-01-14 18:12:47 by sof]

Changes to make the Prelude comply with Haskell 98.

I claim that this completes GHC's implementation of Haskell 98 (at
least feature-wise, but there's bound to be some bugs lurking..)
parent 2a18afab
%
% (c) The AQUA Project, Glasgow University, 1994-1996
% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Array]{Module @Array@}
......@@ -7,17 +7,39 @@
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
module Array (
module Ix, -- export all of Ix
Array, -- Array type is abstract
array, listArray, (!), bounds, indices, elems, assocs,
accumArray, (//), accum, ixmap
) where
module Array
(
module Ix -- export all of Ix
, Array -- Array type is abstract
, array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
, listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b
, (!) -- :: (Ix a) => Array a b -> a -> b
, bounds -- :: (Ix a) => Array a b -> (a,a)
, indices -- :: (Ix a) => Array a b -> [a]
, elems -- :: (Ix a) => Array a b -> [b]
, assocs -- :: (Ix a) => Array a b -> [(a,b)]
, accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
, (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b
, accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
, ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b
-- Array instances:
--
-- Ix a => Functor (Array a)
-- (Ix a, Eq b) => Eq (Array a b)
-- (Ix a, Ord b) => Ord (Array a b)
-- (Ix a, Show a, Show b) => Show (Array a b)
-- (Ix a, Read a, Read b) => Read (Array a b)
--
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
import Ix
import PrelList
--import PrelRead
import PrelArr -- Most of the hard work is done here
import PrelBase
......@@ -42,7 +64,7 @@ infixl 9 !, //
{-# SPECIALISE listArray :: (Int,Int) -> [b] -> Array Int b #-}
listArray :: (Ix a) => (a,a) -> [b] -> Array a b
listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
listArray b vs = array b (zip (range b) vs)
{-# SPECIALISE indices :: Array Int b -> [Int] #-}
indices :: (Ix a) => Array a b -> [a]
......@@ -74,7 +96,7 @@ ixmap b f a = array b [(i, a ! f i) | i <- range b]
\begin{code}
instance Ix a => Functor (Array a) where
map = amap
fmap = amap
instance (Ix a, Eq b) => Eq (Array a b) where
a == a' = assocs a == assocs a'
......
......@@ -24,7 +24,7 @@ import PrelAddr
import PrelIOBase
import PrelST
#endif
import IO ( fail )
import IO ( ioError )
import Ratio
#ifdef __HUGS__
......@@ -64,8 +64,9 @@ getCPUTime = do
fromIntegral x2 * 1000000000 + fromIntegral x3)
* 1000)
else
fail (IOError Nothing UnsupportedOperation "getCPUTime"
"can't get CPU time")
ioError (IOError Nothing UnsupportedOperation
"getCPUTime"
"can't get CPU time")
#else
......@@ -80,8 +81,9 @@ getCPUTime =
fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 +
fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000)
else
fail (IOError Nothing UnsupportedOperation "getCPUTime"
"can't get CPU time")
ioError (IOError Nothing UnsupportedOperation
"getCPUTime"
"can't get CPU time")
#endif
......
%
% (c) The AQUA Project, Glasgow University, 1994-1996
% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Char]{Module @Char@}
......@@ -9,24 +9,31 @@
module Char
(
isAscii, isLatin1, isControl,
isPrint, isSpace, isUpper,
isLower, isAlpha, isDigit,
isOctDigit, isHexDigit, isAlphanum, -- :: Char -> Bool
Char
toUpper, toLower, -- :: Char -> Char
, isAscii, isLatin1, isControl
, isPrint, isSpace, isUpper
, isLower, isAlpha, isDigit
, isOctDigit, isHexDigit, isAlphaNum -- :: Char -> Bool
digitToInt, -- :: Char -> Int
intToDigit, -- :: Int -> Char
, toUpper, toLower -- :: Char -> Char
ord, -- :: Char -> Int
chr, -- :: Int -> Char
readLitChar, -- :: ReadS Char
showLitChar -- :: Char -> ShowS
, digitToInt -- :: Char -> Int
, intToDigit -- :: Int -> Char
, ord -- :: Char -> Int
, chr -- :: Int -> Char
, readLitChar -- :: ReadS Char
, showLitChar -- :: Char -> ShowS
, lexLitChar -- :: ReadS String
, String
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
import PrelBase
import PrelRead (readLitChar)
import PrelRead (readLitChar, lexLitChar)
import {-# SOURCE #-} PrelErr ( error )
\end{code}
......@@ -39,7 +46,7 @@ digitToInt c
| isDigit c = fromEnum c - fromEnum '0'
| c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
| c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
| otherwise = error "Char.digitToInt: not a digit" -- sigh
| otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh
\end{code}
%
% (c) The AQUA Project, Glasgow University, 1994-1997
% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Complex]{Module @Complex@}
\begin{code}
module Complex (
Complex((:+)),
realPart, imagPart, conjugate, mkPolar,
cis, polar, magnitude, phase
) where
module Complex
( Complex((:+))
, realPart -- :: (RealFloat a) => Complex a -> a
, imagPart -- :: (RealFloat a) => Complex a -> a
, conjugate -- :: (RealFloat a) => Complex a -> Complex a
, mkPolar -- :: (RealFloat a) => a -> a -> Complex a
, cis -- :: (RealFloat a) => a -> Complex a
, polar -- :: (RealFloat a) => Complex a -> (a,a)
, magnitude -- :: (RealFloat a) => Complex a -> a
, phase -- :: (RealFloat a) => Complex a -> a
-- Complex instances:
--
-- (RealFloat a) => Eq (Complex a)
-- (RealFloat a) => Read (Complex a)
-- (RealFloat a) => Show (Complex a)
-- (RealFloat a) => Num (Complex a)
-- (RealFloat a) => Fractional (Complex a)
-- (RealFloat a) => Floating (Complex a)
--
-- Implementation checked wrt. Haskell 98 lib report, 1/99.
) where
import Prelude
......@@ -24,7 +42,7 @@ infix 6 :+
%*********************************************************
\begin{code}
data (RealFloat a) => Complex a = !a :+ !a deriving (Eq,Read,Show)
data (RealFloat a) => Complex a = !a :+ !a deriving (Eq, Read, Show)
\end{code}
......@@ -36,8 +54,8 @@ data (RealFloat a) => Complex a = !a :+ !a deriving (Eq,Read,Show)
\begin{code}
realPart, imagPart :: (RealFloat a) => Complex a -> a
realPart (x:+y) = x
imagPart (x:+y) = y
realPart (x :+ _) = x
imagPart (_ :+ y) = y
conjugate :: (RealFloat a) => Complex a -> Complex a
conjugate (x:+y) = x :+ (-y)
......@@ -51,14 +69,15 @@ cis theta = cos theta :+ sin theta
polar :: (RealFloat a) => Complex a -> (a,a)
polar z = (magnitude z, phase z)
magnitude, phase :: (RealFloat a) => Complex a -> a
magnitude :: (RealFloat a) => Complex a -> a
magnitude (x:+y) = scaleFloat k
(sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
where k = max (exponent x) (exponent y)
mk = - k
phase :: (RealFloat a) => Complex a -> a
phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson
phase (x:+y) = atan2 y x
phase (x:+y) = atan2 y x
\end{code}
......@@ -118,7 +137,7 @@ instance (RealFloat a) => Floating (Complex a) where
asin z@(x:+y) = y':+(-x')
where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
acos z@(x:+y) = y'':+(-x'')
acos z = y'':+(-x'')
where (x'':+y'') = log (z + ((-y'):+x'))
(x':+y') = sqrt (1 - z*z)
atan z@(x:+y) = y':+(-x')
......
%
% (c) The AQUA Project, Glasgow University, 1994-1997
% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Directory]{Directory interface}
......@@ -20,24 +20,28 @@ are relative to the current directory.
{-# OPTIONS -#include <sys/stat.h> -#include <dirent.h> -#include "cbits/stgio.h" #-}
module Directory
(
Permissions(Permissions),
createDirectory,
removeDirectory,
renameDirectory,
getDirectoryContents,
getCurrentDirectory,
setCurrentDirectory,
removeFile,
renameFile,
doesFileExist,
doesDirectoryExist,
getPermissions,
setPermissions,
Permissions(Permissions,readable,writable,executable,searchable)
, createDirectory -- :: FilePath -> IO ()
, removeDirectory -- :: FilePath -> IO ()
, renameDirectory -- :: FilePath -> FilePath -> IO ()
, getDirectoryContents -- :: FilePath -> IO [FilePath]
, getCurrentDirectory -- :: IO FilePath
, setCurrentDirectory -- :: FilePath -> IO ()
, removeFile -- :: FilePath -> IO ()
, renameFile -- :: FilePath -> FilePath -> IO ()
, doesFileExist -- :: FilePath -> IO Bool
, doesDirectoryExist -- :: FilePath -> IO Bool
, getPermissions -- :: FilePath -> IO Permissions
, setPermissions -- :: FilePath -> Permissions -> IO ()
#ifndef __HUGS__
getModificationTime
, getModificationTime -- :: FilePath -> IO ClockTime
#endif
) where
......@@ -49,55 +53,13 @@ import PrelIOBase
import PrelHandle
import PrelST
import PrelArr
import PrelPack ( unpackNBytesST )
import PrelPack ( unpackNBytesST, packString, unpackCStringST )
import PrelAddr
import Time ( ClockTime(..) )
#endif
\end{code}
%*********************************************************
%* *
\subsection{Signatures}
%* *
%*********************************************************
\begin{code}
createDirectory :: FilePath -> IO ()
removeDirectory :: FilePath -> IO ()
removeFile :: FilePath -> IO ()
renameDirectory :: FilePath -> FilePath -> IO ()
renameFile :: FilePath -> FilePath -> IO ()
getDirectoryContents :: FilePath -> IO [FilePath]
getCurrentDirectory :: IO FilePath
setCurrentDirectory :: FilePath -> IO ()
doesFileExist :: FilePath -> IO Bool
doesDirectoryExist :: FilePath -> IO Bool
getPermissions :: FilePath -> IO Permissions
setPermissions :: FilePath -> Permissions -> IO ()
#ifndef __HUGS__
getModificationTime :: FilePath -> IO ClockTime
#endif
\end{code}
\begin{code}
#ifdef __HUGS__
foreign import stdcall "libHS_cbits.so" "createDirectory" primCreateDirectory :: CString -> IO Int
foreign import stdcall "libHS_cbits.so" "removeDirectory" primRemoveDirectory :: CString -> IO Int
foreign import stdcall "libHS_cbits.so" "removeFile" primRemoveFile :: CString -> IO Int
foreign import stdcall "libHS_cbits.so" "renameDirectory" primRenameDirectory :: CString -> CString -> IO Int
foreign import stdcall "libHS_cbits.so" "renameFile" primRenameFile :: CString -> CString -> IO Int
foreign import stdcall "libHS_cbits.so" "openDir__" primOpenDir :: CString -> IO Addr
foreign import stdcall "libHS_cbits.so" "readDir__" primReadDir :: Addr -> IO Addr
foreign import stdcall "libHS_cbits.so" "get_dirent_d_name" primGetDirentDName :: Addr -> IO Addr
foreign import stdcall "libHS_cbits.so" "setCurrentDirectory" primSetCurrentDirectory :: CString -> IO Int
foreign import stdcall "libHS_cbits.so" "getCurrentDirectory" primGetCurrentDirectory :: IO Addr
foreign import stdcall "libc.so.6" "free" primFree :: Addr -> IO ()
foreign import stdcall "libc.so.6" "malloc" primMalloc :: Word -> IO Addr
foreign import stdcall "libc.so.6" "chmod" primChmod :: CString -> Word -> IO Int
#endif
\end{code}
%*********************************************************
%* *
\subsection{Permissions}
......@@ -111,7 +73,7 @@ operations are permissible on a file/directory:
\begin{code}
data Permissions
= Permissions {
readable, writeable,
readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
\end{code}
......@@ -154,13 +116,9 @@ The path refers to an existing non-directory object.
\end{itemize}
\begin{code}
createDirectory :: FilePath -> IO ()
createDirectory path = do
#ifdef __HUGS__
rc <- primCreateDirectory (primPackString path)
#else
rc <- _ccall_ createDirectory path
#endif
if rc == 0 then return () else
constructErrorAndFailWithInfo "createDirectory" path
\end{code}
......@@ -200,12 +158,9 @@ The operand refers to an existing non-directory object.
\end{itemize}
\begin{code}
removeDirectory :: FilePath -> IO ()
removeDirectory path = do
#ifdef __HUGS__
rc <- primRemoveDirectory (primPackString path)
#else
rc <- _ccall_ removeDirectory path
#endif
if rc == 0 then
return ()
else
......@@ -241,12 +196,9 @@ The operand refers to an existing directory.
\end{itemize}
\begin{code}
removeFile :: FilePath -> IO ()
removeFile path = do
#ifdef __HUGS__
rc <- primRemoveFile (primPackString path)
#else
rc <- _ccall_ removeFile path
#endif
if rc == 0 then
return ()
else
......@@ -292,12 +244,9 @@ Either path refers to an existing non-directory object.
\end{itemize}
\begin{code}
renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath = do
#ifdef __HUGS__
rc <- primRenameDirectory (primPackString opath) (primPackString npath)
#else
rc <- _ccall_ renameDirectory opath npath
#endif
if rc == 0 then
return ()
else
......@@ -341,12 +290,9 @@ Either path refers to an existing directory.
\end{itemize}
\begin{code}
renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath = do
#ifdef __HUGS__
rc <- primRenameFile (primPackString opath) (primPackString npath)
#else
rc <- _ccall_ renameFile opath npath
#endif
if rc == 0 then
return ()
else
......@@ -379,8 +325,7 @@ The path refers to an existing non-directory object.
\end{itemize}
\begin{code}
--getDirectoryContents :: FilePath -> IO [FilePath]
#ifdef __HUGS__
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
dir <- primOpenDir (primPackString path)
if dir == nullAddr
......@@ -400,31 +345,6 @@ getDirectoryContents path = do
entry <- primUnpackCString str
entries <- loop dir
return (entry:entries)
#else
getDirectoryContents path = do
dir <- _ccall_ openDir__ path
if dir == ``NULL''
then constructErrorAndFailWithInfo "getDirectoryContents" path
else loop dir
where
loop :: Addr -> IO [String]
loop dir = do
dirent_ptr <- _ccall_ readDir__ dir
if (dirent_ptr::Addr) == ``NULL''
then do
-- readDir__ implicitly performs closedir() when the
-- end is reached.
return []
else do
str <- _casm_ `` %r=(char*)((struct dirent*)%0)->d_name; '' dirent_ptr
-- not using the unpackCString function here, since we have to force
-- the unmarshalling of the directory entry right here as subsequent
-- calls to readdir() may overwrite it.
len <- _ccall_ strlen str
entry <- stToIO (unpackNBytesST str len)
entries <- loop dir
return (entry:entries)
#endif
\end{code}
If the operating system has a notion of current directories,
......@@ -449,23 +369,13 @@ The operating system has no notion of current directory.
\end{itemize}
\begin{code}
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
#ifdef __HUGS__
str <- primGetCurrentDirectory
#else
str <- _ccall_ getCurrentDirectory
#endif
if str /= nullAddr
then do
#ifdef __HUGS__
pwd <- primUnpackCString str
primFree str
#else
-- don't use unpackCString (see getDirectoryContents above)
len <- _ccall_ strlen str
pwd <- stToIO (unpackNBytesST str len)
_ccall_ free str
#endif
return pwd
else
constructErrorAndFail "getCurrentDirectory"
......@@ -498,64 +408,58 @@ The path refers to an existing non-directory object.
\end{itemize}
\begin{code}
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
#ifdef __HUGS__
rc <- primSetCurrentDirectory (primPackString path)
#else
rc <- _ccall_ setCurrentDirectory path
#endif
if rc == 0
then return ()
else constructErrorAndFailWithInfo "setCurrentDirectory" path
\end{code}
To clarify, @doesDirectoryExist@ returns True if a file system object
exist, and it's a directory. @doesFileExist@ returns True if the file
system object exist, but it's not a directory (i.e., for every other
file system object that is not a directory.)
\begin{code}
--doesFileExist :: FilePath -> IO Bool
#ifdef __HUGS__
foreign import stdcall "libc.so.6" "access" primAccess :: PrimByteArray -> Int -> IO Int
foreign import stdcall "libHS_cbits.so" "const_F_OK" const_F_OK :: Int
doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
catch
(getFileStatus name >>= \ st -> return (isDirectory st))
(\ _ -> return False)
doesFileExist :: FilePath -> IO Bool
doesFileExist name = do
rc <- primAccess (primPackString name) const_F_OK
return (rc == 0)
#else
doesFileExist name = do
rc <- _ccall_ access name (``F_OK''::Int)
return (rc == 0)
#endif
catch
(getFileStatus name >>= \ st -> return (not (isDirectory st)))
(\ _ -> return False)
--doesDirectoryExist :: FilePath -> IO Bool
doesDirectoryExist name =
(getFileStatus name >>= \ st -> return (isDirectory st))
`catch`
(\ _ -> return False)
foreign import ccall "libHS_cbits.so" "const_F_OK" const_F_OK :: Int
#ifndef __HUGS__
--getModificationTime :: FilePath -> IO ClockTime
getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
getFileStatus name >>= \ st ->
modificationTime st
#endif
--getPermissions :: FilePath -> IO Permissions
getPermissions name =
getFileStatus name >>= \ st ->
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
st <- getFileStatus name
let
fm = fileMode st
isect v = intersectFileMode v fm == v
in
return (
Permissions {
readable = isect ownerReadMode,
writeable = isect ownerWriteMode,
writable = isect ownerWriteMode,
executable = not (isDirectory st) && isect ownerExecuteMode,
searchable = not (isRegularFile st) && isect ownerExecuteMode
}
)
)
--setPermissions :: FilePath -> Permissions -> IO ()
#ifdef __HUGS__
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
read = if r then ownerReadMode else emptyFileMode
......@@ -567,31 +471,12 @@ setPermissions name (Permissions r w e s) = do
rc <- primChmod (primPackString name) mode
if rc == 0
then return ()
else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
#else
setPermissions name (Permissions r w e s) = do
let
read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# }
write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# }
exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# }
mode = I# (word2Int# (read# `or#` write# `or#` exec#))
rc <- _ccall_ chmod name mode
if rc == 0
then return ()
else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
#endif
else ioError (IOError Nothing SystemError "setPermissions" "insufficient permissions")
\end{code}
(Sigh)..copied from Posix.Files to avoid dep. on posix library
\begin{code}
#ifdef __HUGS__
foreign import stdcall "libHS_cbits.so" "sizeof_stat" sizeof_stat :: Int
foreign import stdcall "libHS_cbits.so" "prim_stat" primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
type FileStatus = PrimByteArray
getFileStatus :: FilePath -> IO FileStatus
......@@ -599,23 +484,19 @@ getFileStatus name = do
bytes <- primNewByteArray sizeof_stat
rc <- primStat (primPackString name) bytes
if rc == 0
#ifdef __HUGS__
then primUnsafeFreezeByteArray bytes
else fail (IOError Nothing SystemError "getFileStatus" "")
#else
type FileStatus = ByteArray Int
getFileStatus :: FilePath -> IO FileStatus
getFileStatus name = do
bytes <- stToIO (newCharArray (0,``sizeof(struct stat)''))
rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' name bytes
if rc == 0
then stToIO (unsafeFreezeByteArray bytes)
else fail (IOError Nothing SystemError "getFileStatus" "")
#endif
else ioError (IOError Nothing SystemError "getFileStatus" "")
#ifndef __HUGS__
modificationTime :: FileStatus -> IO ClockTime
modificationTime stat = do
-- ToDo: better, this is ugly stuff.
i1 <- malloc1
_casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1
setFileMode i1 stat
secs <- cvtUnsigned i1
return (TOD secs 0)
where
......@@ -638,62 +519,85 @@ modificationTime stat = do
case unsafeFreezeByteArray# arr# s2# of
(# s3#, frozen# #) ->
(# s3#, J# 1# 1# frozen# #)
#endif
#ifdef __HUGS__
foreign import stdcall "libHS_cbits.so" "get_stat_st_mode" fileMode :: FileStatus -> FileMode
foreign import stdcall "libHS_cbits.so" "prim_S_ISDIR" prim_S_ISDIR :: FileMode -> Int