From: sof Date: Thu, 14 Jan 1999 18:13:05 +0000 (+0000) Subject: [project @ 1999-01-14 18:12:47 by sof] X-Git-Tag: Approx_2487_patches~109 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0d65c1627fcb0aa951c6457c879fdd7626e83a62;p=ghc-hetmet.git [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..) --- diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs index c775047..b5dfbf9 100644 --- a/ghc/lib/std/Array.lhs +++ b/ghc/lib/std/Array.lhs @@ -1,5 +1,5 @@ % -% (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' diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs index 010f556..e02a29e 100644 --- a/ghc/lib/std/CPUTime.lhs +++ b/ghc/lib/std/CPUTime.lhs @@ -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 diff --git a/ghc/lib/std/Char.lhs b/ghc/lib/std/Char.lhs index f5c4899..a471bec 100644 --- a/ghc/lib/std/Char.lhs +++ b/ghc/lib/std/Char.lhs @@ -1,5 +1,5 @@ % -% (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} diff --git a/ghc/lib/std/Complex.lhs b/ghc/lib/std/Complex.lhs index 573beb7..f92144e 100644 --- a/ghc/lib/std/Complex.lhs +++ b/ghc/lib/std/Complex.lhs @@ -1,16 +1,34 @@ % -% (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') diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs index b209404..f5f2611 100644 --- a/ghc/lib/std/Directory.lhs +++ b/ghc/lib/std/Directory.lhs @@ -1,5 +1,5 @@ % -% (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 -#include -#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,7 +53,7 @@ import PrelIOBase import PrelHandle import PrelST import PrelArr -import PrelPack ( unpackNBytesST ) +import PrelPack ( unpackNBytesST, packString, unpackCStringST ) import PrelAddr import Time ( ClockTime(..) ) #endif @@ -58,48 +62,6 @@ import Time ( ClockTime(..) ) %********************************************************* %* * -\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 -foreign import stdcall "libHS_cbits.so" "prim_S_ISREG" prim_S_ISREG :: FileMode -> Int +foreign import ccall "libHS_cbits.so" "set_stat_st_mtime" + setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO () + +#endif isDirectory :: FileStatus -> Bool isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0 isRegularFile :: FileStatus -> Bool isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0 -#else -isDirectory :: FileStatus -> Bool -isDirectory stat = unsafePerformIO $ do - rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat - return (rc /= 0) -isRegularFile :: FileStatus -> Bool -isRegularFile stat = unsafePerformIO $ do - rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat - return (rc /= 0) -#endif +foreign import ccall "libHS_cbits.so" "sizeof_stat" sizeof_stat :: Int +foreign import ccall "libHS_cbits.so" "prim_stat" primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int + +foreign import ccall "libHS_cbits.so" "get_stat_st_mode" fileMode :: FileStatus -> FileMode +foreign import ccall "libHS_cbits.so" "prim_S_ISDIR" prim_S_ISDIR :: FileMode -> Int +foreign import ccall "libHS_cbits.so" "prim_S_ISREG" prim_S_ISREG :: FileMode -> Int \end{code} \begin{code} type FileMode = Word -#ifdef __HUGS__ emptyFileMode :: FileMode unionFileMode :: FileMode -> FileMode -> FileMode intersectFileMode :: FileMode -> FileMode -> FileMode -foreign import stdcall "libHS_cbits.so" "const_S_IRUSR" ownerReadMode :: FileMode -foreign import stdcall "libHS_cbits.so" "const_S_IWUSR" ownerWriteMode :: FileMode -foreign import stdcall "libHS_cbits.so" "const_S_IXUSR" ownerExecuteMode :: FileMode +foreign import ccall "libHS_cbits.so" "const_S_IRUSR" unsafe ownerReadMode :: FileMode +foreign import ccall "libHS_cbits.so" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode +foreign import ccall "libHS_cbits.so" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode +#ifdef __HUGS__ emptyFileMode = primIntToWord 0 unionFileMode = primOrWord intersectFileMode = primAndWord #else -ownerReadMode :: FileMode -ownerReadMode = ``S_IRUSR'' +--ToDo: tidy up. +emptyFileMode = W# (int2Word# 0#) +unionFileMode = orWord +intersectFileMode = andWord +#endif -ownerWriteMode :: FileMode -ownerWriteMode = ``S_IWUSR'' +\end{code} -ownerExecuteMode :: FileMode -ownerExecuteMode = ``S_IXUSR'' +Some defns. to allow us to share code. -intersectFileMode :: FileMode -> FileMode -> FileMode -intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#) +\begin{code} +#ifndef __HUGS__ + +primPackString :: [Char] -> ByteArray Int +primPackString = packString +--ToDo: fix. +primUnpackCString :: Addr -> IO String +primUnpackCString a = stToIO (unpackCStringST a) -fileMode :: FileStatus -> FileMode -fileMode stat = unsafePerformIO ( - _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat) +type PrimByteArray = ByteArray Int +type PrimMutableByteArray s = MutableByteArray RealWorld Int +type CString = PrimByteArray + +orWord, andWord :: Word -> Word -> Word +orWord (W# x#) (W# y#) = W# (x# `or#` y#) +andWord (W# x#) (W# y#) = W# (x# `and#` y#) + +primNewByteArray :: Int -> IO (PrimMutableByteArray s) +primNewByteArray sz_in_bytes = stToIO (newCharArray (0,sz_in_bytes)) #endif +foreign import ccall "libHS_cbits.so" "createDirectory" primCreateDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "removeDirectory" primRemoveDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "removeFile" primRemoveFile :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "renameDirectory" primRenameDirectory :: CString -> CString -> IO Int +foreign import ccall "libHS_cbits.so" "renameFile" primRenameFile :: CString -> CString -> IO Int +foreign import ccall "libHS_cbits.so" "openDir__" primOpenDir :: CString -> IO Addr +foreign import ccall "libHS_cbits.so" "readDir__" primReadDir :: Addr -> IO Addr +foreign import ccall "libHS_cbits.so" "get_dirent_d_name" primGetDirentDName :: Addr -> IO Addr +foreign import ccall "libHS_cbits.so" "setCurrentDirectory" primSetCurrentDirectory :: CString -> IO Int +foreign import ccall "libHS_cbits.so" "getCurrentDirectory" primGetCurrentDirectory :: IO Addr +foreign import ccall "libc.so.6" "free" primFree :: Addr -> IO () +foreign import ccall "libc.so.6" "malloc" primMalloc :: Word -> IO Addr +foreign import ccall "libc.so.6" "chmod" primChmod :: CString -> Word -> IO Int \end{code} + diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs index 7e207f1..1b458cb 100644 --- a/ghc/lib/std/IO.lhs +++ b/ghc/lib/std/IO.lhs @@ -63,6 +63,14 @@ module IO ( -- Non-standard extension (but will hopefully become standard with 1.5) is -- to export the Prelude io functions via IO (in addition to exporting them -- from the prelude...for now.) + IO, + FilePath, -- :: String + IOError, + ioError, -- :: IOError -> IO a + userError, -- :: String -> IOError + catch, -- :: IO a -> (IOError -> IO a) -> IO a + interact, -- :: (String -> String) -> IO () + putChar, -- :: Char -> IO () putStr, -- :: String -> IO () putStrLn, -- :: String -> IO () @@ -70,19 +78,11 @@ module IO ( getChar, -- :: IO Char getLine, -- :: IO String getContents, -- :: IO String - interact, -- :: (String -> String) -> IO () readFile, -- :: FilePath -> IO String writeFile, -- :: FilePath -> String -> IO () appendFile, -- :: FilePath -> String -> IO () readIO, -- :: Read a => String -> IO a readLn, -- :: Read a => IO a - FilePath, -- :: String - fail, -- :: IOError -> IO a - catch, -- :: IO a -> (IOError -> IO a) -> IO a - userError, -- :: String -> IOError - - IO, -- non-standard, amazingly enough. - IOError, -- ditto -- extensions hPutBuf, @@ -114,7 +114,7 @@ import PrelEither ( Either(..) ) import PrelAddr ( Addr(..), nullAddr ) import PrelArr ( ByteArray ) import PrelPack ( unpackNBytesAccST ) -import PrelException ( fail, catch ) +import PrelException ( ioError, catch ) #ifndef __PARALLEL_HASKELL__ import PrelForeign ( ForeignObj ) @@ -159,7 +159,7 @@ instance Eq HandlePosn where -- Type declared in IOBase, instance here because it -- depends on PrelRead.(Read Maybe) instance. instance Read BufferMode where - readsPrec p = + readsPrec _ = readParen False (\r -> let lr = lex r in @@ -196,7 +196,7 @@ hWaitForInput handle msecs = wantReadableHandle "hWaitForInput" handle $ \ handle_ -> do rc <- CCALL(inputReady) (haFO__ handle_) (msecs::Int) -- ConcHask: SAFE, won't block writeHandle handle handle_ - case rc of + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hWaitForInput" @@ -212,7 +212,7 @@ hGetChar handle = let fo = haFO__ handle_ intc <- mayBlock fo (CCALL(fileGetc) fo) -- ConcHask: UNSAFE, may block writeHandle handle handle_ - if intc /= (-1) + if intc /= ((-1)::Int) then return (chr intc) else constructErrorAndFail "hGetChar" @@ -290,13 +290,13 @@ lazyReadChar :: Handle -> Addr -> IO String lazyReadBlock handle fo = do buf <- CCALL(getBufStart) fo (0::Int) bytes <- mayBlock fo (CCALL(readBlock) fo) -- ConcHask: UNSAFE, may block. - case bytes of + case (bytes::Int) of -3 -> -- buffering has been turned off, use lazyReadChar instead lazyReadChar handle fo -2 -> return "" -1 -> -- an error occurred, close the handle withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block. + CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flushing-} -- ConcHask: SAFE, won't block. writeHandle handle (handle_ { haType__ = ClosedHandle, haFO__ = nullFile__ }) return "" @@ -306,13 +306,13 @@ lazyReadBlock handle fo = do lazyReadLine handle fo = do bytes <- mayBlock fo (CCALL(readLine) fo) -- ConcHask: UNSAFE, may block. - case bytes of + case (bytes::Int) of -3 -> -- buffering has been turned off, use lazyReadChar instead lazyReadChar handle fo -2 -> return "" -- handle closed by someone else, stop reading. -1 -> -- an error occurred, close the handle withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block + CCALL(closeFile) (haFO__ handle_) (0::Int){- don't bother flushing-} -- ConcHask: SAFE, won't block writeHandle handle (handle_ { haType__ = ClosedHandle, haFO__ = nullFile__ }) return "" @@ -323,7 +323,7 @@ lazyReadLine handle fo = do lazyReadChar handle fo = do char <- mayBlock fo (CCALL(readChar) fo) -- ConcHask: UNSAFE, may block. - case char of + case (char::Int) of -4 -> -- buffering is now block-buffered, use lazyReadBlock instead lazyReadBlock handle fo @@ -332,7 +332,7 @@ lazyReadChar handle fo = do -2 -> return "" -1 -> -- error, silently close handle. withHandle handle $ \ handle_ -> do - CCALL(closeFile) (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block + CCALL(closeFile) (haFO__ handle_) (0::Int){-don't bother flusing-} -- ConcHask: SAFE, won't block writeHandle handle (handle_{ haType__ = ClosedHandle, haFO__ = nullFile__ }) return "" @@ -451,12 +451,12 @@ writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else writeLines :: Addr -> Addr -> Int -> Int -> String -> IO () #endif -writeLines obj buf bf@(I# bufLen) (I# initPos#) s = +writeLines obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #) + case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #) shoveString :: Int# -> [Char] -> IO () shoveString n ls = @@ -545,12 +545,12 @@ writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO () #else writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO () #endif -writeBlocks obj buf bf@(I# bufLen) (I# initPos#) s = +writeBlocks obj buf (I# bufLen) (I# initPos#) s = let write_char :: Addr -> Int# -> Char# -> IO () - write_char (A# buf) n# c# = + write_char (A# buf#) n# c# = IO $ \ s# -> - case (writeCharOffAddr# buf n# c# s#) of s2# -> (# s2#, () #) + case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #) shoveString :: Int# -> [Char] -> IO () shoveString n ls = @@ -595,7 +595,7 @@ writeChars :: ForeignObj -> String -> IO () #else writeChars :: Addr -> String -> IO () #endif -writeChars fo "" = return () +writeChars _fo "" = return () writeChars fo (c:cs) = do rc <- mayBlock fo (CCALL(filePutc) fo c) -- ConcHask: UNSAFE, may block. if rc == 0 @@ -649,7 +649,7 @@ bracket before after m = do after x case rs of Right r -> return r - Left e -> fail e + 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 @@ -659,7 +659,7 @@ bracket_ before after m = do after x case rs of Right r -> return r - Left e -> fail e + Left e -> ioError e \end{code} %********************************************************* diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs index ed6a367..db17b45 100644 --- a/ghc/lib/std/Ix.lhs +++ b/ghc/lib/std/Ix.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[Ix]{Module @Ix@} @@ -9,8 +9,24 @@ module Ix ( - Ix(range, index, inRange), - rangeSize + Ix + ( range -- :: (Ix a) => (a,a) -> [a] + , index -- :: (Ix a) => (a,a) -> a -> Int + , inRange -- :: (Ix a) => (a,a) -> a -> Bool + ) + , rangeSize -- :: (Ix a) => (a,a) -> Int + -- Ix instances: + -- + -- Ix Char + -- Ix Int + -- Ix Integer + -- Ix Bool + -- Ix Ordering + -- Ix () + -- (Ix a, Ix b) => Ix (a, b) + -- ... + + -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where import {-# SOURCE #-} PrelErr ( error ) @@ -25,7 +41,7 @@ import PrelBase %********************************************************* \begin{code} -class (Show a, Ord a) => Ix a where +class ({-Show a,-} Ord a) => Ix a where range :: (a,a) -> [a] index :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool @@ -41,50 +57,41 @@ class (Show a, Ord a) => Ix a where \begin{code} instance Ix Char where range (c,c') = [c..c'] - index b@(c,c') ci + index b@(c,_) ci | inRange b ci = fromEnum ci - fromEnum c - | otherwise = indexCharError ci b - inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c' - where i = fromEnum ci + | otherwise = indexError ci b "Char" + inRange (m,n) i = m <= i && i <= n instance Ix Int where range (m,n) = [m..n] - index b@(m,n) i + index b@(m,_) i | inRange b i = i - m - | otherwise = indexIntError i b + | otherwise = indexError i b "Int" inRange (m,n) i = m <= i && i <= n -- abstract these errors from the relevant index functions so that -- the guts of the function will be small enough to inline. -{-# NOINLINE indexCharError #-} -indexCharError :: Char -> (Char,Char) -> a -indexCharError ci b - = error (showString "Ix{Char}.index: Index " . - showParen True (showsPrec 0 ci) . +{-# NOINLINE indexError #-} +indexError :: Show a => a -> (a,a) -> String -> b +indexError i rng tp + = error (showString "Ix{" . showString tp . showString "}.index: Index " . + showParen True (showsPrec 0 i) . showString " out of range " $ - showParen True (showsPrec 0 b) "") - -{-# NOINLINE indexIntError #-} -indexIntError :: Int -> (Int,Int) -> a -indexIntError i b - = error (showString "Ix{Int}.index: Index " . - showParen True (showsPrec 0 i) . - showString " out of range " $ - showParen True (showsPrec 0 b) "") + showParen True (showsPrec 0 rng) "") -- Integer instance is in PrelNum ---------------------------------------------------------------------- instance Ix Bool where -- as derived range (l,u) = map toEnum [fromEnum l .. fromEnum u] - index (l,u) i = fromEnum i - fromEnum l + index (l,_) i = fromEnum i - fromEnum l inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u ---------------------------------------------------------------------- instance Ix Ordering where -- as derived range (l,u) = map toEnum [fromEnum l .. fromEnum u] - index (l,u) i = fromEnum i - fromEnum l + index (l,_) i = fromEnum i - fromEnum l inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u ---------------------------------------------------------------------- diff --git a/ghc/lib/std/List.lhs b/ghc/lib/std/List.lhs index 1e133a6..990b040 100644 --- a/ghc/lib/std/List.lhs +++ b/ghc/lib/std/List.lhs @@ -1,41 +1,134 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[List]{Module @Lhar@} \begin{code} -module List ( - {- - This list follows the type signatures for the - standard List interface. -- 8/97 - -} - elemIndex, elemIndices, - find, findIndex, findIndices, - nub, nubBy, - delete, deleteBy, (\\), deleteFirstsBy, - union, unionBy, - intersect, intersectBy, - intersperse, transpose, partition, - group, groupBy, - inits, tails, - isPrefixOf, isSuffixOf, - mapAccumL, mapAccumR, - sort, sortBy, - insertBy, - maximumBy, minimumBy, - genericTake, genericDrop, genericSplitAt, - genericIndex, genericReplicate, genericLength, - - zip4, zip5, zip6, zip7, - zipWith4, zipWith5, zipWith6, zipWith7, - unzip4, unzip5, unzip6, unzip7 - - ) where +module List + ( + []((:), []) + + , elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int + , elemIndices -- :: (Eq a) => a -> [a] -> [Int] + + , find -- :: (a -> Bool) -> [a] -> Maybe a + , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int + , findIndices -- :: (a -> Bool) -> [a] -> [Int] + + , nub -- :: (Eq a) => [a] -> [a] + , nubBy -- :: (a -> a -> Bool) -> [a] -> [a] + + , delete -- :: (Eq a) => a -> [a] -> [a] + , deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a] + , (\\) -- :: (Eq a) => [a] -> [a] -> [a] + , deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , union -- :: (Eq a) => [a] -> [a] -> [a] + , unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , intersect -- :: (Eq a) => [a] -> [a] -> [a] + , intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] + + , intersperse -- :: a -> [a] -> [a] + , transpose -- :: [[a]] -> [[a]] + , partition -- :: (a -> Bool) -> [a] -> ([a], [a]) + + , group -- :: Eq a => [a] -> [[a]] + , groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]] + + , inits -- :: [a] -> [[a]] + , tails -- :: [a] -> [[a]] + + , isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool + , isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool + + , mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) + , mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) + + , sort -- :: (Ord a) => [a] -> [a] + , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a] + + , insert -- :: (Ord a) => a -> [a] -> [a] + , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a] + + , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a + , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a + + , genericLength -- :: (Integral a) => [b] -> a + , genericTake -- :: (Integral a) => a -> [b] -> [b] + , genericDrop -- :: (Integral a) => a -> [b] -> [b] + , genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b]) + , genericIndex -- :: (Integral a) => [b] -> a -> b + , genericReplicate -- :: (Integral a) => a -> b -> [b] + + , unfoldr -- :: (a -> Maybe (b,a)) -> a -> (a,[b]) + + , zip4, zip5, zip6, zip7 + , zipWith4, zipWith5, zipWith6, zipWith7 + , unzip4, unzip5, unzip6, unzip7 + + , map -- :: ( a -> b ) -> [a] -> [b] + , (++) -- :: [a] -> [a] -> [a] + , concat -- :: [[a]] -> [a] + , filter -- :: (a -> Bool) -> [a] -> [a] + , head -- :: [a] -> a + , last -- :: [a] -> a + , tail -- :: [a] -> [a] + , init -- :: [a] -> [a] + , null -- :: [a] -> Bool + , length -- :: [a] -> Int + , (!!) -- :: [a] -> Int -> a + , foldl -- :: (a -> b -> a) -> a -> [b] -> a + , foldl1 -- :: (a -> a -> a) -> [a] -> a + , scanl -- :: (a -> b -> a) -> a -> [b] -> [a] + , scanl1 -- :: (a -> a -> a) -> [a] -> [a] + , foldr -- :: (a -> b -> b) -> b -> [a] -> b + , foldr1 -- :: (a -> a -> a) -> [a] -> a + , scanr -- :: (a -> b -> b) -> b -> [a] -> [b] + , scanr1 -- :: (a -> a -> a) -> [a] -> [a] + , iterate -- :: (a -> a) -> a -> [a] + , repeat -- :: a -> [a] + , replicate -- :: Int -> a -> [a] + , cycle -- :: [a] -> [a] + , take -- :: Int -> [a] -> [a] + , drop -- :: Int -> [a] -> [a] + , splitAt -- :: Int -> [a] -> ([a], [a]) + , takeWhile -- :: (a -> Bool) -> [a] -> [a] + , dropWhile -- :: (a -> Bool) -> [a] -> [a] + , span -- :: (a -> Bool) -> [a] -> ([a], [a]) + , break -- :: (a -> Bool) -> [a] -> ([a], [a]) + + , lines -- :: String -> [String] + , words -- :: String -> [String] + , unlines -- :: [String] -> String + , unwords -- :: [String] -> String + , reverse -- :: [a] -> [a] + , and -- :: [Bool] -> Bool + , or -- :: [Bool] -> Bool + , any -- :: (a -> Bool) -> [a] -> Bool + , all -- :: (a -> Bool) -> [a] -> Bool + , elem -- :: a -> [a] -> Bool + , notElem -- :: a -> [a] -> Bool + , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b + , sum -- :: (Num a) => [a] -> a + , product -- :: (Num a) => [a] -> a + , maximum -- :: (Ord a) => [a] -> a + , minimum -- :: (Ord a) => [a] -> a + , concatMap -- :: (a -> [b]) -> [a] -> [b] + , zip -- :: [a] -> [b] -> [(a,b)] + , zip3 + , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c] + , zipWith3 + , unzip -- :: [(a,b)] -> ([a],[b]) + , unzip3 + + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + ) where import Prelude import Maybe ( listToMaybe ) -import PrelBase ( Int(..) ) +import PrelBase ( Int(..), map, (++) ) import PrelGHC ( (+#) ) infix 5 \\ @@ -66,11 +159,11 @@ findIndices :: (a -> Bool) -> [a] -> [Int] findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] #else -- Efficient definition -findIndices p xs = loop 0# p xs +findIndices p ls = loop 0# ls where - loop n p [] = [] - loop n p (x:xs) | p x = I# n : loop (n +# 1#) p xs - | otherwise = loop (n +# 1#) p xs + loop _ [] = [] + loop n (x:xs) | p x = I# n : loop (n +# 1#) xs + | otherwise = loop (n +# 1#) xs #endif isPrefixOf :: (Eq a) => [a] -> [a] -> Bool @@ -90,7 +183,9 @@ nub = nubBy (==) nub l = nub' l [] where nub' [] _ = [] - nub' (x:xs) l = if x `elem` l then nub' xs l else x : nub' xs (x:l) + nub' (x:xs) ls + | x `elem` ls = nub' xs ls + | otherwise = x : nub' xs (x:ls) #endif nubBy :: (a -> a -> Bool) -> [a] -> [a] @@ -101,11 +196,13 @@ nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) nubBy eq l = nubBy' l [] where nubBy' [] _ = [] - nubBy' (x:xs) l = if elemBy eq x l then nubBy' xs l else x : nubBy' xs (x:l) + nubBy' (x:xs) ls + | elemBy eq x ls = nubBy' xs ls + | otherwise = x : nubBy' xs (x:ls) --not exported: elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool -elemBy eq _ [] = False +elemBy _ _ [] = False elemBy eq x (y:ys) = x `eq` y || elemBy eq x ys #endif @@ -115,7 +212,7 @@ delete :: (Eq a) => a -> [a] -> [a] delete = deleteBy (==) deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] -deleteBy eq x [] = [] +deleteBy _ _ [] = [] deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys -- list difference (non-associative). In the result of xs \\ ys, @@ -140,14 +237,14 @@ intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- intersperse sep inserts sep between the elements of its list argument. -- e.g. intersperse ',' "abcde" == "a,b,c,d,e" intersperse :: a -> [a] -> [a] -intersperse sep [] = [] -intersperse sep [x] = [x] +intersperse _ [] = [] +intersperse _ [x] = [x] intersperse sep (x:xs) = x : sep : intersperse sep xs transpose :: [[a]] -> [[a]] -transpose = foldr - (\xs xss -> zipWith (:) xs (xss ++ repeat [])) - [] +transpose [] = [] +transpose ([] : xss) = transpose xss +transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) -- partition takes a predicate and a list and returns a pair of lists: @@ -174,7 +271,7 @@ mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list -> acc -- Initial accumulator -> [x] -- Input list -> (acc, [y]) -- Final accumulator and result list -mapAccumL f s [] = (s, []) +mapAccumL _ s [] = (s, []) mapAccumL f s (x:xs) = (s'',y:ys) where (s', y ) = f s x (s'',ys) = mapAccumL f s' xs @@ -190,26 +287,29 @@ mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list -> acc -- Initial accumulator -> [x] -- Input list -> (acc, [y]) -- Final accumulator and result list -mapAccumR f s [] = (s, []) +mapAccumR _ s [] = (s, []) mapAccumR f s (x:xs) = (s'', y:ys) where (s'',y ) = f s' x (s', ys) = mapAccumR f s xs \end{code} \begin{code} +insert :: Ord a => a -> [a] -> [a] +insert e ls = insertBy (compare) e ls + insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] -insertBy cmp x [] = [x] +insertBy _ x [] = [x] insertBy cmp x ys@(y:ys') = case cmp x y of GT -> y : insertBy cmp x ys' _ -> x : ys maximumBy :: (a -> a -> a) -> [a] -> a -maximumBy max [] = error "List.maximumBy: empty list" +maximumBy _ [] = error "List.maximumBy: empty list" maximumBy max xs = foldl1 max xs minimumBy :: (a -> a -> a) -> [a] -> a -minimumBy min [] = error "List.minimumBy: empty list" +minimumBy _ [] = error "List.minimumBy: empty list" minimumBy min xs = foldl1 min xs genericLength :: (Num i) => [b] -> i @@ -317,7 +417,7 @@ group :: (Eq a) => [a] -> [[a]] group = groupBy (==) groupBy :: (a -> a -> Bool) -> [a] -> [[a]] -groupBy eq [] = [] +groupBy _ [] = [] groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs @@ -353,11 +453,13 @@ sort l = qsort compare l [] -- rest is not exported: -- qsort is stable and does not concatenate. -qsort cmp [] r = r -qsort cmp [x] r = x:r +qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +qsort _ [] r = r +qsort _ [x] r = x:r qsort cmp (x:xs) r = qpart cmp x xs [] [] r -- qpart partitions and sorts the sublists +qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] qpart cmp x [] rlt rge r = -- rlt and rge are in reverse order and must be sorted with an -- anti-stable sorting @@ -368,10 +470,12 @@ qpart cmp x (y:ys) rlt rge r = _ -> qpart cmp x ys rlt (y:rge) r -- rqsort is as qsort but anti-stable, i.e. reverses equal elements -rqsort cmp [] r = r -rqsort cmp [x] r = x:r +rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +rqsort _ [] r = r +rqsort _ [x] r = x:r rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r +rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] rqpart cmp x [] rle rgt r = qsort cmp rle (x:qsort cmp rgt r) rqpart cmp x (y:ys) rle rgt r = @@ -381,3 +485,20 @@ rqpart cmp x (y:ys) rle rgt r = #endif /* USE_REPORT_PRELUDE */ \end{code} + +\begin{verbatim} + unfoldr f' (foldr f z xs) == (z,xs) + + if the following holds: + + f' (f x y) = Just (x,y) + f' z = Nothing +\end{verbatim} + +\begin{code} +unfoldr :: (b -> Maybe (a, b)) -> b -> [a] +unfoldr f b = + case f b of + Just (a,new_b) -> a : unfoldr f new_b + Nothing -> [] +\end{code} diff --git a/ghc/lib/std/Locale.lhs b/ghc/lib/std/Locale.lhs index c76ee9f..3248c8b 100644 --- a/ghc/lib/std/Locale.lhs +++ b/ghc/lib/std/Locale.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1995-97 +% (c) The GRASP/AQUA Project, Glasgow University, 1995-99 % \section[Time]{Haskell 1.4 Locale Library} diff --git a/ghc/lib/std/Main.hi-boot b/ghc/lib/std/Main.hi-boot index ebfbee8..642e4a6 100644 --- a/ghc/lib/std/Main.hi-boot +++ b/ghc/lib/std/Main.hi-boot @@ -8,4 +8,4 @@ __interface Main 1 where __export Main main ; -1 main :: PrelIOBase.IO PrelBase.(); +1 main :: __forall [a] => PrelIOBase.IO a; diff --git a/ghc/lib/std/Maybe.lhs b/ghc/lib/std/Maybe.lhs index 119c20c..32d4490 100644 --- a/ghc/lib/std/Maybe.lhs +++ b/ghc/lib/std/Maybe.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[Maybe]{Module @Maybe@} @@ -11,25 +11,25 @@ The standard Haskell 1.3 library for working with module Maybe ( - Maybe(..), -- non-standard + Maybe(Nothing,Just) -- instance of: Eq, Ord, Show, Read, - -- Functor, Monad, MonadZero, MonadPlus + -- Functor, Monad, MonadPlus - maybe, -- :: b -> (a -> b) -> Maybe a -> b + , maybe -- :: b -> (a -> b) -> Maybe a -> b - isJust, -- :: Maybe a -> Bool - fromJust, -- :: Maybe a -> a - fromMaybe, -- :: a -> Maybe a -> a - listToMaybe, -- :: [a] -> Maybe a - maybeToList, -- :: Maybe a -> [a] - catMaybes, -- :: [Maybe a] -> [a] - mapMaybe, -- :: (a -> Maybe b) -> [a] -> [b] - unfoldr -- :: (a -> Maybe (b,a)) -> a -> (a,[b]) + , isJust -- :: Maybe a -> Bool + , isNothing -- :: Maybe a -> Bool + , fromJust -- :: Maybe a -> a + , fromMaybe -- :: a -> Maybe a -> a + , listToMaybe -- :: [a] -> Maybe a + , maybeToList -- :: Maybe a -> [a] + , catMaybes -- :: [Maybe a] -> [a] + , mapMaybe -- :: (a -> Maybe b) -> [a] -> [b] + -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where import PrelErr ( error ) -import Monad ( filter ) import PrelList import PrelMaybe import PrelBase @@ -47,6 +47,10 @@ isJust :: Maybe a -> Bool isJust Nothing = False isJust _ = True +isNothing :: Maybe a -> Bool +isNothing Nothing = True +isNothing _ = False + fromJust :: Maybe a -> a fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck fromJust (Just x) = x @@ -62,45 +66,16 @@ listToMaybe :: [a] -> Maybe a listToMaybe [] = Nothing listToMaybe (a:_) = Just a -{- OLD, NOT EXPORTED: -findMaybe :: (a -> Bool) -> [a] -> Maybe a -findMaybe p = listToMaybe . filter p --} - catMaybes :: [Maybe a] -> [a] catMaybes ls = [x | Just x <- ls] mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f [] = [] +mapMaybe _ [] = [] mapMaybe f (x:xs) = let rs = mapMaybe f xs in case f x of Nothing -> rs Just r -> r:rs -{- OLD, NOT EXPORTED: -joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -joinMaybe f m1 m2 = - case m1 of - Nothing -> m2 - Just v1 -> case m2 of {Nothing -> m1; Just v2 -> Just (f v1 v2)} --} - \end{code} -\begin{verbatim} - unfoldr f' (foldr f z xs) == (z,xs) - - if the following holds: - - f' (f x y) = Just (x,y) - f' z = Nothing -\end{verbatim} - -\begin{code} -unfoldr :: (a -> Maybe (b, a)) -> a -> (a,[b]) -unfoldr f x = - case f x of - Just (y,x') -> let (x'',ys) = unfoldr f x' in (x'',y:ys) - Nothing -> (x,[]) -\end{code} diff --git a/ghc/lib/std/Monad.lhs b/ghc/lib/std/Monad.lhs index 1421209..d47921b 100644 --- a/ghc/lib/std/Monad.lhs +++ b/ghc/lib/std/Monad.lhs @@ -1,76 +1,116 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[Monad]{Module @Monad@} \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module Monad ( - Functor(..), - Monad(..), MonadZero(..), MonadPlus(..), - - -- Prelude monad functions - accumulate, sequence, - mapM, mapM_, guard, filter, concat, applyM, - - -- Standard Monad interface: - join, -- :: (Monad m) => m (m a) -> m a - mapAndUnzipM, -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) - zipWithM, -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] - zipWithM_, -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () - foldM, -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a - when, -- :: (Monad m) => Bool -> m () -> m () - unless, -- :: (Monad m) => Bool -> m () -> m () - ap, -- :: (Monad m) => (m (a -> b)) -> (m a) -> m b - liftM, liftM2, - liftM3, liftM4, - liftM5 - ) where +module Monad + ( MonadPlus ( -- class context: Monad + mzero -- :: (MonadPlus m) => m a + , mplus -- :: (MonadPlus m) => m a -> m a -> m a + ) + , join -- :: (Monad m) => m (m a) -> m a + , guard -- :: (Monad m) => Bool -> m () + , when -- :: (Monad m) => Bool -> m () -> m () + , unless -- :: (Monad m) => Bool -> m () -> m () + , ap -- :: (Monad m) => (m (a -> b)) -> (m a) -> m b + , msum -- :: (MonadPlus m) => [m a] -> m a + , filterM -- :: (Monad m) => (a -> m Bool) -> [m a] -> m [a] + , mapAndUnzipM -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) + , zipWithM -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] + , zipWithM_ -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () + , foldM -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a + + , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b) + , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c) + , liftM3 -- :: ... + , liftM4 -- :: ... + , liftM5 -- :: ... + + , Monad((>>=), (>>), return, fail) + , Functor(fmap) + + , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b] + , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m () + , sequence -- :: (Monad m) => [m a] -> m [a] + , sequence_ -- :: (Monad m) => [m a] -> m () + , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b + ) where import PrelList import PrelTup import PrelBase +import PrelMaybe ( Maybe(..) ) \end{code} %********************************************************* %* * +\subsection{Monadic classes: @MonadPlus@} +%* * +%********************************************************* + + +\begin{code} +class Monad m => MonadPlus m where + mzero :: m a + mplus :: m a -> m a -> m a + +instance MonadPlus [] where + mzero = [] + mplus = (++) + +instance MonadPlus Maybe where + mzero = Nothing + + Nothing `mplus` ys = ys + xs `mplus` _ys = xs +\end{code} + + +%********************************************************* +%* * \subsection{Functions mandated by the Prelude} %* * %********************************************************* \begin{code} -accumulate :: Monad m => [m a] -> m [a] -accumulate [] = return [] -accumulate (m:ms) = do { x <- m; xs <- accumulate ms; return (x:xs) } +sequence :: Monad m => [m a] -> m [a] +sequence [] = return [] +sequence (m:ms) = do { x <- m; xs <- sequence ms; return (x:xs) } -sequence :: Monad m => [m a] -> m () -sequence = foldr (>>) (return ()) +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 f as = sequence (map f as) mapM_ :: Monad m => (a -> m b) -> [a] -> m () -mapM_ f as = sequence (map f as) +mapM_ f as = sequence_ (map f as) -guard :: MonadZero m => Bool -> m () -guard p = if p then return () else zero +guard :: MonadPlus m => Bool -> m () +guard pred + | pred = return () + | otherwise = mzero -- This subsumes the list-based filter function. -{-# SPECIALISE filter :: (a -> Bool) -> [a] -> [a] #-} -filter :: MonadZero m => (a -> Bool) -> m a -> m a -filter p = applyM (\x -> if p x then return x else zero) +filterM :: (Monad m) => ( a -> m Bool ) -> [a] -> m [a] +filterM _predM [] = return [] +filterM predM (x:xs) = do + flg <- predM x + ys <- filterM predM xs + return (if flg then x:ys else ys) -- This subsumes the list-based concat function. -{-# SPECIALISE concat :: [[a]] -> [a] #-} -concat :: MonadPlus m => [m a] -> m a -concat = foldr (++) zero +msum :: MonadPlus m => [m a] -> m a +msum = foldr mplus mzero -{-# SPECIALISE applyM :: (a -> [b]) -> [a] -> [b] #-} -applyM :: Monad m => (a -> m b) -> m a -> m b -applyM f x = x >>= f +{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} +(=<<) :: Monad m => (a -> m b) -> m a -> m b +f =<< x = x >>= f \end{code} @@ -85,16 +125,16 @@ join :: (Monad m) => m (m a) -> m a join x = x >>= id mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) -mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip +mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWithM f xs ys = accumulate (zipWith f xs ys) +zipWithM f xs ys = sequence (zipWith f xs ys) zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () -zipWithM_ f xs ys = sequence (zipWith f xs ys) +zipWithM_ f xs ys = sequence_ (zipWith f xs ys) foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a -foldM f a [] = return a +foldM _ a [] = return a foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs unless :: (Monad m) => Bool -> m () -> m () diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs index 9a88cc2..f38e426 100644 --- a/ghc/lib/std/Numeric.lhs +++ b/ghc/lib/std/Numeric.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1997-98 +% (c) The AQUA Project, Glasgow University, 1997-99 % \section[Numeric]{Numeric interface} @@ -10,24 +10,28 @@ Odds and ends, mostly functions for reading and showing \begin{code} {-# OPTIONS -fno-implicit-prelude #-} module Numeric - ( - fromRat, - showSigned, - readSigned, - showInt, - readInt, - readDec, readOct, readHex, - - showEFloat, - showFFloat, - showGFloat, - showFloat, - readFloat, + ( fromRat -- :: (RealFloat a) => Rational -> a + , showSigned -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS + , readSigned -- :: (Real a) => ReadS a -> ReadS a + , showInt -- :: Integral a => a -> ShowS + , readInt -- :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a + + , readDec -- :: (Integral a) => ReadS a + , readOct -- :: (Integral a) => ReadS a + , readHex -- :: (Integral a) => ReadS a + + , 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 + , readFloat -- :: (RealFloat a) => ReadS a + - floatToDigits, - lexDigits + , floatToDigits -- :: (RealFloat a) => Integer -> a -> ([Int], Int) + , lexDigits -- :: ReadS String + -- Implementation checked wrt. Haskell 98 lib report, 1/99. ) where import PrelBase @@ -40,43 +44,11 @@ import PrelErr ( error ) \end{code} -%********************************************************* -%* * -\subsection[Numeric-signatures]{Signatures} -%* * -%********************************************************* - -Interface on offer: - -\begin{pseudocode} -fromRat :: (RealFloat a) => Rational -> a - -showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS -readSigned :: (Real a) => ReadS a -> ReadS a - -showInt :: Integral a => a -> ShowS -readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a - -readDec :: (Integral a) => ReadS a -readOct :: (Integral a) => ReadS a -readHex :: (Integral a) => ReadS a - -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 - -readFloat :: (RealFloat a) => ReadS a - -floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) -lexDigits :: ReadS String -\end{pseudocode} - \begin{code} showInt :: Integral a => a -> ShowS -showInt n r - | n < 0 = error "Numeric.showInt: can't show negative numbers" - | otherwise = go n r +showInt i rs + | i < 0 = error "Numeric.showInt: can't show negative numbers" + | otherwise = go i rs where go n r = case quotRem n 10 of { (n', d) -> diff --git a/ghc/lib/std/PrelAddr.lhs b/ghc/lib/std/PrelAddr.lhs index dab7f89..d91ecf9 100644 --- a/ghc/lib/std/PrelAddr.lhs +++ b/ghc/lib/std/PrelAddr.lhs @@ -30,7 +30,8 @@ data Word = W# Word# deriving (Eq, Ord) instance Show Addr where showsPrec p (A# a) = showsPrec p (I# (addr2Int# a)) -nullAddr = ``NULL'' :: Addr +nullAddr :: Addr +nullAddr = ``NULL'' plusAddr :: Addr -> Int -> Addr plusAddr (A# addr) (I# off) = A# (int2Addr# (addr2Int# addr +# off)) diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs index a034346..bc3a4b4 100644 --- a/ghc/lib/std/PrelArr.lhs +++ b/ghc/lib/std/PrelArr.lhs @@ -122,22 +122,23 @@ bounds (Array b _) = b #ifdef USE_FOLDR_BUILD {-# INLINE array #-} #endif -array ixs@(ix_start, ix_end) ivs = +array ixs ivs = runST ( ST $ \ s -> case (newArray ixs arrEleBottom) of { ST new_array_thing -> case (new_array_thing s) of { (# s#, arr@(MutableArray _ arr#) #) -> let - fill_in s# [] = s# - fill_in s# ((i,v):ivs) = - case (index ixs i) of { I# n# -> - case writeArray# arr# n# v s# of { s2# -> - fill_in s2# ivs }} + fill_in s1# [] = s1# + fill_in s1# ((i,v):is) = + case (index ixs i) of { I# n# -> + case writeArray# arr# n# v s1# of { s2# -> + fill_in s2# is }} in - case (fill_in s# ivs) of { s# -> + case (fill_in s# ivs) of { s1# -> case (freezeArray arr) of { ST freeze_array_thing -> - freeze_array_thing s# }}}}) + freeze_array_thing s1# }}}}) +arrEleBottom :: a arrEleBottom = error "(Array.!): undefined array element" fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s () @@ -158,8 +159,6 @@ old_array // ivs fill_it_in arr ivs freezeArray arr ) - where - bottom = error "(Array.//): error in copying old array\n" zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s () -- zap_with_f: reads an elem out first, then uses "f" on that and the new value @@ -180,8 +179,6 @@ accum f old_array ivs zap_with_f f arr ivs freezeArray arr ) - where - bottom = error "Array.accum: error in copying old array\n" accumArray f zero ixs ivs = runST (do @@ -213,7 +210,7 @@ might be different, though. \begin{code} newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) -newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray +newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) {-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), @@ -428,7 +425,6 @@ writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# -> %********************************************************* \begin{code} -{- 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) @@ -439,7 +435,7 @@ freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) MutableArray s IPr elt -> ST s (Array IPr elt) #-} {-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} --} + freezeArray (MutableArray ixs arr#) = ST $ \ s# -> case rangeSize ixs of { I# n# -> case freeze arr# n# s# of { (# s2#, frozen# #) -> @@ -449,9 +445,9 @@ freezeArray (MutableArray ixs arr#) = ST $ \ s# -> -> Int# -- size of thing to be frozen -> State# s -- the Universe and everything -> (# State# s, Array# ele #) - freeze arr# n# s# + freeze m_arr# n# s# = case newArray# n# init s# of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeArray# newarr2# s3# }} where @@ -463,11 +459,11 @@ freezeArray (MutableArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableArray# s ele #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case readArray# from# cur# s# of { (# s1#, ele #) -> + = case readArray# from# cur# st# of { (# s1#, ele #) -> case writeArray# to# cur# ele s1# of { s2# -> copy (cur# +# 1#) end# from# to# s2# }} @@ -482,9 +478,9 @@ freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# n# s# - = case (newCharArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze arr1# n# s1# + = case (newCharArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -493,13 +489,13 @@ freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case (readCharArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeCharArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# + = case (readCharArray# from# cur# st#) of { (# s2#, ele #) -> + case (writeCharArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# }} freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# -> @@ -512,9 +508,9 @@ freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# n# s# - = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze m_arr# n# s# + = case (newIntArray# n# s#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -523,13 +519,13 @@ freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# end# from# to# s# + copy cur# end# from# to# s1# | cur# ==# end# - = (# s#, to# #) + = (# s1#, to# #) | otherwise - = case (readIntArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeIntArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# + = case (readIntArray# from# cur# s1#) of { (# s2#, ele #) -> + case (writeIntArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# }} freezeWordArray (MutableByteArray ixs arr#) = ST $ \ s# -> @@ -542,9 +538,9 @@ freezeWordArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# n# s# - = case (newWordArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze m_arr# n# s1# + = case (newWordArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -553,14 +549,13 @@ freezeWordArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# end# from# to# s# - | cur# ==# end# - = (# s#, to# #) - | otherwise - = case (readWordArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeWordArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# - }} + copy cur# end# from# to# st# + | cur# ==# end# = (# st#, to# #) + | otherwise = + case (readWordArray# from# cur# st#) of { (# s2#, ele #) -> + case (writeWordArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# + }} freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# -> case rangeSize ixs of { I# n# -> @@ -572,9 +567,9 @@ freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# n# s# - = case (newAddrArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze m_arr# n# s1# + = case (newAddrArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# m_arr# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -583,13 +578,13 @@ freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case (readAddrArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeAddrArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# + = case (readAddrArray# from# cur# st#) of { (# st1#, ele #) -> + case (writeAddrArray# to# cur# ele st1#) of { st2# -> + copy (cur# +# 1#) end# from# to# st2# }} unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) @@ -625,9 +620,9 @@ thawArray (Array ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, MutableArray# s ele #) - thaw arr# n# s# + thaw arr1# n# s# = case newArray# n# init s# of { (# s2#, newarr1# #) -> - copy 0# n# arr# newarr1# s2# } + copy 0# n# arr1# newarr1# s2# } where init = error "thawArray: element not copied" @@ -637,12 +632,12 @@ thawArray (Array ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableArray# s ele #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case indexArray# from# cur# of { (# _, ele #) -> - case writeArray# to# cur# ele s# of { s1# -> + = case indexArray# from# cur# of { (# _, ele #) -> + case writeArray# to# cur# ele st# of { s1# -> copy (cur# +# 1#) end# from# to# s1# }} diff --git a/ghc/lib/std/PrelArrExtra.lhs b/ghc/lib/std/PrelArrExtra.lhs index 5f94e2e..a09f051 100644 --- a/ghc/lib/std/PrelArrExtra.lhs +++ b/ghc/lib/std/PrelArrExtra.lhs @@ -32,9 +32,9 @@ freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# end# s# - = case (newFloatArray# end# s#) of { (# s2#, newarr1# #) -> - case copy 0# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze arr1# end# s# + = case (newFloatArray# end# s#) of { (# s2#, newarr1# #) -> + case copy 0# arr1# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -43,13 +43,13 @@ freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# from# to# s# + copy cur# from# to# s1# | cur# ==# end# - = (# s#, to# #) + = (# s1#, to# #) | otherwise - = case (readFloatArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeFloatArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) from# to# s2# + = case (readFloatArray# from# cur# s1#) of { (# s2#, ele #) -> + case (writeFloatArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) from# to# s3# }} freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# -> @@ -62,9 +62,9 @@ freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -- the Universe and everything -> (# State# s, ByteArray# #) - freeze arr# n# s# - = case (newDoubleArray# n# s#) of { (# s2#, newarr1# #) -> - case copy 0# n# arr# newarr1# s2# of { (# s3#, newarr2# #) -> + freeze arr1# n# s1# + = case (newDoubleArray# n# s1#) of { (# s2#, newarr1# #) -> + case copy 0# n# arr1# newarr1# s2# of { (# s3#, newarr2# #) -> unsafeFreezeByteArray# newarr2# s3# }} where @@ -73,12 +73,12 @@ freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# -> -> State# s -> (# State# s, MutableByteArray# s #) - copy cur# end# from# to# s# + copy cur# end# from# to# st# | cur# ==# end# - = (# s#, to# #) + = (# st#, to# #) | otherwise - = case (readDoubleArray# from# cur# s#) of { (# s1#, ele #) -> - case (writeDoubleArray# to# cur# ele s1#) of { s2# -> - copy (cur# +# 1#) end# from# to# s2# + = case (readDoubleArray# from# cur# st#) of { (# s2#, ele #) -> + case (writeDoubleArray# to# cur# ele s2#) of { s3# -> + copy (cur# +# 1#) end# from# to# s3# }} \end{code} diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index 387a530..48dc8cf 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -31,117 +31,6 @@ infixr 0 $ \end{code} -\begin{code} -{- --------------- Stage 1 ----------------------- - -data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) - -- to avoid weird names like con2tag_[]# -instance Functor [] where - map f [] = [] - map f (x:xs) = f x : [] -- map f xs - -class Functor f where - map :: (a -> b) -> f a -> f b - -data Bool = False | True -data Int = I# Int# -data Double = D# Double# -data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) - -- (avoids weird-named functions, e.g., con2tag_()# - -data Maybe a = Nothing | Just a -data Ordering = LT | EQ | GT -- deriving( Eq, Ord ) - -type String = [Char] - -data Char = C# Char# - -y = let f :: Char -> Int - f x = x - in f - --------------- Stage 2 ----------------------- -not True = False -not False = True -True && x = x -False && x = False -otherwise = True - -maybe :: b -> (a -> b) -> Maybe a -> b -maybe n f Nothing = n -maybe n f (Just x) = f x - --------------- Stage 3 ----------------------- -class Eq a where - (==), (/=) :: a -> a -> Bool - - x /= y = not (x == y) - --- f :: Eq a => a -> a -> Bool -f x y = x == y - -g :: Eq a => a -> a -> Bool -g x y = f x y - --------------- Stage 4 ----------------------- - -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 } - -eqInt (I# x) (I# y) = x ==# y - -instance Eq Int where - (==) x y = x `eqInt` y - -instance Ord Int where - compare x y = error "help" - -class Bounded a where - minBound, maxBound :: a - - -type ShowS = String -> String - -class Show a where - showsPrec :: Bool -> a -> ShowS - showList :: [a] -> ShowS - - showList ls = showList__ (showsPrec True) ls - -showList__ :: (a -> ShowS) -> [a] -> ShowS -showList__ showx [] = showString "[]" - -showString :: String -> ShowS -showString = (++) - -[] ++ [] = [] - -shows :: (Show a) => a -> ShowS -shows = showsPrec True - --- show :: (Show a) => a -> String ---show x = shows x "" --} -\end{code} - - %********************************************************* %* * \subsection{Standard classes @Eq@, @Ord@, @Bounded@ @@ -153,6 +42,7 @@ class Eq a where (==), (/=) :: a -> a -> Bool x /= y = not (x == y) + x == y = not (x /= y) class (Eq a) => Ord a where compare :: a -> a -> Ordering @@ -179,26 +69,23 @@ class Bounded a where %********************************************************* %* * -\subsection{Monadic classes @Functor@, @Monad@, @MonadZero@, @MonadPlus@} +\subsection{Monadic classes @Functor@, @Monad@ } %* * %********************************************************* \begin{code} class Functor f where - map :: (a -> b) -> f a -> f b + fmap :: (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 + fail :: String -> m a m >> k = m >>= \_ -> k + fail s = error s -class (Monad m) => MonadZero m where - zero :: m a - -class (MonadZero m) => MonadPlus m where - (++) :: m a -> m a -> m a \end{code} @@ -210,6 +97,7 @@ class (MonadZero m) => MonadPlus m where \begin{code} class Enum a where + succ, pred :: a -> a toEnum :: Int -> a fromEnum :: a -> Int enumFrom :: a -> [a] -- [n..] @@ -217,6 +105,8 @@ class Enum a where enumFromTo :: a -> a -> [a] -- [n..m] enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + succ = toEnum . (+1) . fromEnum + pred = toEnum . (+(-1)) . fromEnum enumFromTo n m = map toEnum [fromEnum n .. fromEnum m] enumFromThenTo n n' m = map toEnum [fromEnum n, fromEnum n' .. fromEnum m] @@ -228,7 +118,8 @@ class (Eq a, Show a) => Num a where fromInteger :: Integer -> a fromInt :: Int -> a -- partain: Glasgow extension - x - y = x + negate y + x - y = x + negate y + negate x = 0 - x fromInt (I# i#) = fromInteger (case int2Integer# i# of (# a, s, d #) -> J# a s d) -- Go via the standard class-op if the @@ -236,14 +127,10 @@ class (Eq a, Show a) => Num a where \end{code} \begin{code} -{-# SPECIALISE succ :: Int -> Int #-} -{-# SPECIALISE pred :: Int -> Int #-} -succ, pred :: Enum a => a -> a -succ = toEnum . (+1) . fromEnum -pred = toEnum . (subtract 1) . fromEnum - -chr = (toEnum :: Int -> Char) -ord = (fromEnum :: Char -> Int) +chr :: Int -> Char +chr = toEnum +ord :: Char -> Int +ord = fromEnum ord_0 :: Num a => a ord_0 = fromInt (ord '0') @@ -265,9 +152,12 @@ type ShowS = String -> String class Show a where showsPrec :: Int -> a -> ShowS + show :: a -> String showList :: [a] -> ShowS - showList ls = showList__ (showsPrec 0) ls + showList ls = showList__ (showsPrec 0) ls + showsPrec _ x s = show x ++ s + show x = showsPrec 0 x "" \end{code} %********************************************************* @@ -280,10 +170,13 @@ class Show a where data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) -- to avoid weird names like con2tag_[]# + + instance (Eq a) => Eq [a] where [] == [] = True (x:xs) == (y:ys) = x == y && xs == ys - xs == ys = False + _xs == _ys = False + xs /= ys = if (xs == ys) then False else True instance (Ord a) => Ord [a] where @@ -296,35 +189,32 @@ instance (Ord a) => Ord [a] where 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 (_:_) [] = GT + compare [] (_:_) = LT compare (x:xs) (y:ys) = case compare x y of LT -> LT GT -> GT EQ -> compare xs ys +map :: (a -> b) -> [a] -> [b] +map _ [] = [] +map f (x:xs) = f x : map f xs + +(++) :: [a] -> [a] -> [a] +[] ++ ys = ys +(x:xs) ++ ys = x : (xs ++ ys) + instance Functor [] where - map f [] = [] - map f (x:xs) = f x : map f xs + fmap = map instance Monad [] where m >>= k = foldr ((++) . k) [] m m >> k = foldr ((++) . (\ _ -> k)) [] m return x = [x] - -instance MonadZero [] where - zero = [] - -instance MonadPlus [] where -#ifdef USE_REPORT_PRELUDE - xs ++ ys = foldr (:) ys xs -#else - [] ++ ys = ys - (x:xs) ++ ys = x : (xs ++ ys) -#endif + fail _ = [] instance (Show a) => Show [a] where - showsPrec p = showList + showsPrec _ = showList showList ls = showList__ (showsPrec 0) ls \end{code} @@ -335,7 +225,7 @@ The rest of the prelude list functions are in PrelList. \begin{code} foldr :: (a -> b -> b) -> b -> [a] -> b -foldr f z [] = z +foldr _ z [] = z foldr f z (x:xs) = f x (foldr f z xs) -- takeWhile, applied to a predicate p and a list xs, returns the longest @@ -344,13 +234,13 @@ foldr f z (x:xs) = f x (foldr f z xs) -- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. takeWhile :: (a -> Bool) -> [a] -> [a] -takeWhile p [] = [] +takeWhile _ [] = [] takeWhile p (x:xs) | p x = x : takeWhile p xs | otherwise = [] dropWhile :: (a -> Bool) -> [a] -> [a] -dropWhile p [] = [] +dropWhile _ [] = [] dropWhile p xs@(x:xs') | p x = dropWhile p xs' | otherwise = xs @@ -360,44 +250,26 @@ dropWhile p xs@(x:xs') #ifdef USE_REPORT_PRELUDE (x:_) !! 0 = x (_:xs) !! n | n > 0 = xs !! (n-1) -(_:_) !! _ = error "PreludeList.!!: negative index" -[] !! _ = error "PreludeList.!!: index too large" +(_:_) !! _ = error "Prelude.(!!): negative index" +[] !! _ = error "Prelude.(!!): index too large" #else -- HBC version (stolen), then unboxified -- The semantics is not quite the same for error conditions -- in the more efficient version. -- -_ !! n | n < 0 = error "(!!){PreludeList}: negative index\n" +_ !! n | n < 0 = error "Prelude.(!!): negative index\n" xs !! n = sub xs (case n of { I# n# -> n# }) where sub :: [a] -> Int# -> a - sub [] _ = error "(!!){PreludeList}: index too large\n" - sub (x:xs) n# = if n# ==# 0# - then x - else sub xs (n# -# 1#) + sub [] _ = error "Prelude.(!!): index too large\n" + sub (y:ys) n# = if n# ==# 0# + then y + else sub ys (n# -# 1#) #endif \end{code} %********************************************************* %* * -\subsection{Type @Void@} -%* * -%********************************************************* - -The type @Void@ is built in, but it needs a @Show@ instance. - -\begin{code} -void :: Void -void = error "You tried to evaluate void" - -instance Show Void where - showsPrec p f = showString "<>" - showList ls = showList__ (showsPrec 0) ls -\end{code} - - -%********************************************************* -%* * \subsection{Type @Bool@} %* * %********************************************************* @@ -409,8 +281,8 @@ data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) (&&), (||) :: Bool -> Bool -> Bool True && x = x -False && x = False -True || x = True +False && _ = False +True || _ = True False || x = x not :: Bool -> Bool @@ -453,6 +325,8 @@ instance Ord () where compare () () = EQ instance Enum () where + succ x = x + pred x = x toEnum 0 = () toEnum _ = error "Prelude.Enum.().toEnum: argument not 0" fromEnum () = 0 @@ -462,7 +336,7 @@ instance Enum () where enumFromThenTo () () () = [()] instance Show () where - showsPrec p () = showString "()" + showsPrec _ () = showString "()" showList ls = showList__ (showsPrec 0) ls \end{code} @@ -489,9 +363,16 @@ type String = [Char] data Char = C# Char# deriving (Eq, Ord) instance Enum Char where + succ c@(C# c#) + | not (ord# c# ==# 255#) = C# (chr# (ord# c# +# 1#)) + | otherwise = error ("Prelude.Enum{Char}.succ: out of range " ++ show c) + pred c@(C# c#) + | not (ord# c# ==# 0#) = C# (chr# (ord# c# -# 1#)) + | otherwise = error ("Prelude.Enum{Char}.succ: out of range " ++ show c) + toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i) | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i)) - fromEnum (C# c) = I# (ord# c) + fromEnum (C# c) = I# (ord# c) enumFrom (C# c) = efttCh (ord# c) 1# (># 255#) enumFromTo (C# c1) (C# c2) = efttCh (ord# c1) 1# (># (ord# c2)) @@ -505,27 +386,27 @@ instance Enum Char where | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# (ord# c3)) efttCh :: Int# -> Int# -> (Int# -> Bool) -> [Char] -efttCh now step done - = go now +efttCh init step done + = go init where go now | done now = [] | otherwise = C# (chr# now) : go (now +# step) instance Show Char where - showsPrec p '\'' = showString "'\\''" - showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + showsPrec _ '\'' = showString "'\\''" + showsPrec _ 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 + showl ('"':xs) = showString "\\\"" . showl xs + showl (x:xs) = showLitChar x . showl xs \end{code} \begin{code} isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool -isAscii c = fromEnum c < 128 + isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool +isAscii c = c < '\x80' isLatin1 c = c <= '\xff' isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' isPrint c = not (isControl c) @@ -556,19 +437,22 @@ isDigit c = c >= '0' && c <= '9' isOctDigit c = c >= '0' && c <= '7' isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f' -isAlphanum c = isAlpha c || isDigit c +isAlphaNum c = isAlpha c || isDigit c -- Case-changing operations toUpper, toLower :: Char -> Char -toUpper c | isLower c && c /= '\xDF' && c /= '\xFF' - = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') - | otherwise = c +toUpper c + | isLower c && c /= '\xDF' && c /= '\xFF' + = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') + | otherwise + = c toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a') | otherwise = c +asciiTab :: [String] 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", @@ -600,11 +484,14 @@ instance Ord Int where max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x } min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y } +compareInt :: Int -> Int -> Ordering (I# x) `compareInt` (I# y) | x <# y = LT | x ==# y = EQ | otherwise = GT instance Enum Int where + succ x = x+1 + pred x = x-1 toEnum x = x fromEnum x = x @@ -627,15 +514,15 @@ instance Enum Int where #endif efttInt :: Int# -> Int# -> (Int# -> Bool) -> [Int] -efttInt now step done - = go now +efttInt init step done + = go init where go now | done now = [] | otherwise = I# now : go (now +# step) eftInt :: Int# -> Int# -> [Int] -eftInt now step - = go now +eftInt init step + = go init where go now = I# now : go (now +# step) @@ -679,6 +566,7 @@ instance Eq Integer where (J# a1 s1 d1) /= (J# a2 s2 d2) = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0# + \end{code} %********************************************************* @@ -689,7 +577,7 @@ instance Eq Integer where \begin{code} instance Show (a -> b) where - showsPrec p f = showString "<>" + showsPrec _ _ = showString "<>" showList ls = showList__ (showsPrec 0) ls @@ -727,21 +615,6 @@ asTypeOf :: a -> a -> a asTypeOf = const \end{code} - -%********************************************************* -%* * -\subsection{Miscellaneous} -%* * -%********************************************************* - - -\begin{code} -data Lift a = Lift a -\end{code} - - - - %********************************************************* %* * \subsection{Support code for @Show@} @@ -752,9 +625,6 @@ data Lift a = Lift a shows :: (Show a) => a -> ShowS shows = showsPrec 0 -show :: (Show a) => a -> String -show x = shows x "" - showChar :: Char -> ShowS showChar = (:) @@ -766,11 +636,11 @@ showParen b p = if b then showChar '(' . p . showChar ')' else p showList__ :: (a -> ShowS) -> [a] -> ShowS -showList__ showx [] = showString "[]" +showList__ _ [] = showString "[]" showList__ showx (x:xs) = showChar '[' . showx x . showl xs where showl [] = showChar ']' - showl (x:xs) = showChar ',' . showx x . showl xs + showl (y:ys) = showChar ',' . showx y . showl ys showSpace :: ShowS showSpace = {-showChar ' '-} \ xs -> ' ' : xs @@ -794,6 +664,7 @@ showLitChar '\v' = showString "\\v" showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") showLitChar c = showString ('\\' : asciiTab!!ord c) +protectEsc :: (Char -> Bool) -> ShowS -> ShowS protectEsc p f = f . cont where cont s@(c:_) | p c = "\\&" ++ s cont s = s @@ -801,8 +672,8 @@ protectEsc p f = f . cont intToDigit :: Int -> Char intToDigit i | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) - | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i -10) - | otherwise = error ("Char.intToDigit: not a digit" ++ show i) + | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10) + | otherwise = error ("Char.intToDigit: not a digit " ++ show i) \end{code} @@ -811,26 +682,21 @@ Code specific for Ints. \begin{code} showSignedInt :: Int -> Int -> ShowS showSignedInt p (I# n) r - = -- from HBC version; support code follows - if n <# 0# && p > 6 then '(':itos n++(')':r) else itos n ++ r - -itos :: Int# -> String -itos n = - if n <# 0# then - if negateInt# n <# 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 <# 10# then - C# (chr# (n +# ord# '0'#)) : cs - else - itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# +# ord# '0'#)) : cs) + | n <# 0# && p > 6 = '(':itos n (')':r) + | otherwise = itos n r + +itos :: Int# -> String -> String +itos n r + | n >=# 0# = itos' n r + | negateInt# n <# 0# = -- n is minInt, a difficult number + itos (n `quotInt#` 10#) (itos' (negateInt# (n `remInt#` 10#)) r) + | otherwise = '-':itos' (negateInt# n) r + where + itos' :: Int# -> String -> String + itos' x cs + | x <# 10# = C# (chr# (x +# ord# '0'#)) : cs + | otherwise = itos' (x `quotInt#` 10#) + (C# (chr# (x `remInt#` 10# +# ord# '0'#)) : cs) \end{code} %********************************************************* @@ -846,12 +712,17 @@ used in the case of partial applications, etc. {-# INLINE eqInt #-} {-# INLINE neInt #-} +plusInt, minusInt, timesInt, quotInt, remInt :: Int -> Int -> Int plusInt (I# x) (I# y) = I# (x +# y) minusInt(I# x) (I# y) = I# (x -# y) timesInt(I# x) (I# y) = I# (x *# y) quotInt (I# x) (I# y) = I# (quotInt# x y) remInt (I# x) (I# y) = I# (remInt# x y) + +negateInt :: Int -> Int negateInt (I# x) = I# (negateInt# x) + +gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool gtInt (I# x) (I# y) = x ># y geInt (I# x) (I# y) = x >=# y eqInt (I# x) (I# y) = x ==# y @@ -866,8 +737,10 @@ it's nice to have them in PrelBase. \begin{code} {-# INLINE int2Integer #-} {-# INLINE addr2Integer #-} +int2Integer :: Int# -> Integer int2Integer i = case int2Integer# i of (# a, s, d #) -> J# a s d -addr2Integer s = case addr2Integer# s of (# a, s, d #) -> J# a s d +addr2Integer :: Addr# -> Integer +addr2Integer x = case addr2Integer# x of (# a, s, d #) -> J# a s d integer_0, integer_1, integer_2, integer_m1 :: Integer integer_0 = int2Integer 0# diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs index f5a5d26..aa70ab3 100644 --- a/ghc/lib/std/PrelConc.lhs +++ b/ghc/lib/std/PrelConc.lhs @@ -17,20 +17,26 @@ module PrelConc ( -- Forking and suchlike forkIO, killThread, - seq, par, fork, - {-threadDelay, threadWaitRead, threadWaitWrite, -} + par, fork, seq, + {-threadDelay, threadWaitRead, threadWaitWrite,-} -- MVars - MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar + MVar + , newMVar + , newEmptyMVar + , takeMVar + , putMVar + , readMVar + , swapMVar + -- use with care (see comment.) + , isEmptyMVar ) where import PrelBase -import {-# SOURCE #-} PrelErr ( parError ) +import PrelErr ( parError, seqError ) import PrelST ( ST(..), STret(..), liftST ) -import PrelIOBase ( IO(..), MVar(..), liftIO, unsafePerformIO ) -import PrelErr ( parError ) +import PrelIOBase ( IO(..), MVar(..), unsafePerformIO ) import PrelBase ( Int(..) ) -import PrelErr ( seqError ) infixr 0 `par`, `fork` \end{code} @@ -49,11 +55,11 @@ data ThreadId = ThreadId ThreadId# forkIO :: IO () -> IO ThreadId forkIO action = IO $ \ s -> - case (fork# action s) of (# s, id #) -> (# s, ThreadId id #) + case (fork# action s) of (# s1, id #) -> (# s1, ThreadId id #) killThread :: ThreadId -> IO () killThread (ThreadId id) = IO $ \ s -> - case (killThread# id s) of s -> (# s, () #) + case (killThread# id s) of s1 -> (# s1, () #) -- "seq" is defined a bit wierdly (see below) -- @@ -77,7 +83,7 @@ par, fork :: a -> b -> b #if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__) par x y = case (par# x) of { 0# -> parError; _ -> y } #else -par x y = y +par _ y = y #endif fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y @@ -140,6 +146,23 @@ swapMVar mvar new = takeMVar mvar >>= \ old -> putMVar mvar new >> return old + +{- + Low-level op. for checking whether an MVar is filled-in or not. + Notice that the boolean value returned is just a snapshot of + the state of the MVar. By the time you get to react on its result, + the MVar may have been filled (or emptied) - so be extremely + careful when using this operation. + + If you can re-work your abstractions to avoid having to + depend on isEmptyMVar, then you're encouraged to do so, + i.e., consider yourself warned about the imprecision in + general of isEmptyMVar :-) +-} +isEmptyMVar :: MVar a -> IO Bool +isEmptyMVar (MVar mv#) = IO $ \ s# -> + case isEmptyMVar# mv# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) \end{code} @@ -162,7 +185,7 @@ specified file descriptor is available for reading (just like select). @threadWaitWrite@ is similar, but for writing on a file descriptor. \begin{code} -{- Not yet -- SDM +{- Not yet -- SDM threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () threadDelay (I# x#) = IO $ \ s# -> diff --git a/ghc/lib/std/PrelEither.lhs b/ghc/lib/std/PrelEither.lhs index 71969aa..ada0a96 100644 --- a/ghc/lib/std/PrelEither.lhs +++ b/ghc/lib/std/PrelEither.lhs @@ -15,6 +15,6 @@ import PrelBase data Either a b = Left a | Right b deriving (Eq, Ord, Show {- Read -} ) either :: (a -> c) -> (b -> c) -> Either a b -> c -either f g (Left x) = f x -either f g (Right y) = g y +either f _ (Left x) = f x +either _ g (Right y) = g y \end{code} diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs index ecc3846..a96044c 100644 --- a/ghc/lib/std/PrelErr.lhs +++ b/ghc/lib/std/PrelErr.lhs @@ -28,6 +28,7 @@ module PrelErr , error -- :: String -> a , assertError -- :: String -> Bool -> a -> a + ) where import PrelBase @@ -48,11 +49,11 @@ import PrelForeign ( StablePtr, deRefStablePtr ) -- 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 (:) [] +--build = error "GHCbase.build" +--augment = error "GHCbase.augment" \end{code} %********************************************************* @@ -176,6 +177,7 @@ It prints location message details \begin{code} +untangle :: String -> String -> String untangle coded message = location ++ ": " @@ -184,10 +186,10 @@ untangle coded message ++ "\n" where (location, details) - = case (span not_bar coded) of { (location, rest) -> + = case (span not_bar coded) of { (loc, rest) -> case rest of - ('|':details) -> (location, ' ' : details) - _ -> (location, "") + ('|':det) -> (loc, ' ' : det) + _ -> (loc, "") } not_bar c = c /= '|' \end{code} diff --git a/ghc/lib/std/PrelException.hi-boot b/ghc/lib/std/PrelException.hi-boot index df8a13a..8082910 100644 --- a/ghc/lib/std/PrelException.hi-boot +++ b/ghc/lib/std/PrelException.hi-boot @@ -6,6 +6,6 @@ --------------------------------------------------------------------------- __interface PrelErr 1 where -__export PrelException fail catch; -1 fail :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ; +__export PrelException ioError catch; +1 ioError :: __forall [a] => PrelIOBase.IOError -> PrelIOBase.IO a ; 1 catch :: __forall [a] => PrelIOBase.IO a -> (PrelIOBase.IOError -> PrelIOBase.IO a) -> PrelIOBase.IO a ; diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs index db87533..586d68e 100644 --- a/ghc/lib/std/PrelException.lhs +++ b/ghc/lib/std/PrelException.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelException.lhs,v 1.3 1999/01/07 16:39:06 simonm Exp $ +% $Id: PrelException.lhs,v 1.4 1999/01/14 18:12:57 sof Exp $ % % (c) The GRAP/AQUA Project, Glasgow University, 1998 % @@ -25,7 +25,7 @@ Exception datatype and operations. \begin{code} data Exception - = IOException IOError -- IO exceptions (from 'fail') + = IOException IOError -- IO exceptions (from 'ioError') | ArithException ArithException -- Arithmetic exceptions | ErrorCall String -- Calls to 'error' | NoMethodError String -- A non-existent method was invoked @@ -75,7 +75,8 @@ instance Show Exception where showsPrec _ (RecConError err) = showString err showsPrec _ (RecUpdError err) = showString err showsPrec _ (AssertionFailed err) = showString err - showsPrec _ (DynException err) = showString "unknown exception" + showsPrec _ (AsyncException e) = shows e + showsPrec _ (DynException _err) = showString "unknown exception" -- Primitives: @@ -103,7 +104,7 @@ catchException :: IO a -> (Exception -> IO a) -> IO a catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s) #else catchException m k = IO $ \s -> case catch# (liftIO m s) (\exs -> liftIO (k exs) s) - of STret s r -> (# s, r #) + of STret s1 r -> (# s1, r #) #endif catch :: IO a -> (IOError -> IO a) -> IO a @@ -116,7 +117,7 @@ Why is this stuff here? To avoid recursive module dependencies of course. \begin{code} -fail :: IOError -> IO a -fail err = throw (IOException err) +ioError :: IOError -> IO a +ioError err = throw (IOException err) \end{code} diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index 8af2609..1a1cbe8 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -15,9 +15,6 @@ __export PrelGHC CCallable CReturnable - Void --- void CAF is defined in PrelBase - -- Magical assert thingy assert @@ -40,6 +37,7 @@ __export PrelGHC newMVar# takeMVar# putMVar# + isEmptyMVar# -- Parallel seq# @@ -73,7 +71,6 @@ __export PrelGHC +# -# *# - /# quotInt# remInt# negateInt# @@ -95,7 +92,6 @@ __export PrelGHC not# xor# shiftL# - shiftRA# shiftRL# int2Word# word2Int# diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index b433372..ec3c896 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -19,7 +19,7 @@ import PrelArr ( newVar, readVar, writeVar, ByteArray ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase -import PrelException ( Exception(..), throw, catch, fail, catchException ) +import PrelException ( throw, ioError, catchException ) import PrelMaybe ( Maybe(..) ) import PrelAddr ( Addr, nullAddr ) import PrelBounded () -- get at Bounded Int instance. @@ -31,7 +31,7 @@ import PrelConc import Ix #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( makeForeignObj, writeForeignObj ) +import PrelForeign ( makeForeignObj ) #endif #endif /* ndef(__HUGS__) */ @@ -167,20 +167,26 @@ 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. + \begin{code} stdin, stdout, stderr :: Handle stdout = unsafePerformIO (do - rc <- CCALL(getLock) 1 1 -- ConcHask: SAFE, won't block - case rc of + rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do #ifndef __CONCURRENT_HASKELL__ - fo <- CCALL(openStdFile) 1 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (1::Int) + (1::Int){-flush on close-} + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #else - fo <- CCALL(openStdFile) 1 (1{-flush on close-} {-+ 128 don't block on I/O-}) - 0{-writeable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (1::Int) + ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #endif + -- NOTE: turn off non-blocking I/O until + -- we've got proper support for threadWait{Read,Write} #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo @@ -202,15 +208,18 @@ stdout = unsafePerformIO (do ) stdin = unsafePerformIO (do - rc <- CCALL(getLock) 0 0 -- ConcHask: SAFE, won't block - case rc of + rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do #ifndef __CONCURRENT_HASKELL__ - fo <- CCALL(openStdFile) 0 0{-don't flush on close -} 1{-readable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (0::Int) + (0::Int){-don't flush on close -} + (1::Int){-readable-} -- ConcHask: SAFE, won't block #else - fo <- CCALL(openStdFile) 0 (0{-flush on close-} {- + 128 don't block on I/O-}) - 1{-readable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (0::Int) + ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int) + (1::Int){-readable-} -- ConcHask: SAFE, won't block #endif #ifndef __PARALLEL_HASKELL__ @@ -231,15 +240,18 @@ stdin = unsafePerformIO (do stderr = unsafePerformIO (do - rc <- CCALL(getLock) 2 1 -- ConcHask: SAFE, won't block - case rc of + rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do #ifndef __CONCURRENT_HASKELL__ - fo <- CCALL(openStdFile) 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (2::Int) + (1::Int){-flush on close-} + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #else - fo <- CCALL(openStdFile) 2 (1{-flush on close-} {- + 128 don't block on I/O-}) - 0{-writeable-} -- ConcHask: SAFE, won't block + fo <- CCALL(openStdFile) (2::Int) + ((1{-flush on close-} {- + 128 don't block on I/O-})::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #endif #ifndef __PARALLEL_HASKELL__ @@ -273,7 +285,9 @@ openFile fp im = openFileEx fp (TextMode im) openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx f m = do - fo <- CCALL(openFile) (primPackString f) file_mode binary file_flags -- ConcHask: SAFE, won't block + fo <- CCALL(openFile) (primPackString f) (file_mode::Int) + (binary::Int) + (file_flags::Int) -- ConcHask: SAFE, won't block if fo /= nullAddr then do #ifndef __PARALLEL_HASKELL__ fo <- makeForeignObj fo @@ -287,8 +301,8 @@ openFileEx f m = do where (imo, binary) = case m of - BinaryMode imo -> (imo, 1) - TextMode imo -> (imo, 0) + BinaryMode bmo -> (bmo, 1) + TextMode tmo -> (tmo, 0) #ifndef __CONCURRENT_HASKELL__ file_flags = file_flags' @@ -340,14 +354,14 @@ hClose :: Handle -> IO () hClose handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hClose" handle _ -> do - rc <- CCALL(closeFile) (haFO__ handle_) 1{-flush if you can-} -- ConcHask: SAFE, won't block + rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block {- We explicitly close a file object so that we can be told if there were any errors. Note that after @hClose@ has been performed, the ForeignObj embedded in the Handle @@ -356,7 +370,7 @@ hClose handle = is finalised. (we overwrite the file ptr in the underlying FileObject with a NULL as part of closeFile()) -} - if rc == 0 + if rc == (0::Int) then writeHandle handle (handle_{ haType__ = ClosedHandle, haFO__ = nullFile__ }) @@ -386,9 +400,9 @@ hFileSize :: Handle -> IO Integer hFileSize handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hFileSize" handle @@ -396,7 +410,7 @@ hFileSize handle = writeHandle handle handle_ ioe_closedHandle "hFileSize" handle #ifdef __HUGS__ - other -> do + _ -> do mem <- primNewByteArray sizeof_int64 rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block writeHandle handle handle_ @@ -406,7 +420,7 @@ hFileSize handle = else constructErrorAndFail "hFileSize" #else - 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 @@ -418,7 +432,7 @@ hFileSize handle = result@(J# _ _ d#) -> do rc <- CCALL(fileSize) (haFO__ handle_) d# -- ConcHask: SAFE, won't block writeHandle handle handle_ - if rc == 0 then + if rc == (0::Int) then return result else constructErrorAndFail "hFileSize" @@ -484,16 +498,17 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of BlockBuffering (Just n) - | n <= 0 -> fail (IOError (Just handle) + | n <= 0 -> ioError + (IOError (Just handle) InvalidArgument "hSetBuffering" ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified. _ -> withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hSetBuffering" handle @@ -620,7 +635,7 @@ hSeek handle mode offset = let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block #else -hSeek handle mode offset@(J# _ s# d#) = +hSeek handle mode (J# _ s# d#) = wantSeekableHandle "hSeek" handle $ \ handle_ -> do let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block @@ -659,9 +674,9 @@ hIsOpen :: Handle -> IO Bool hIsOpen handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ return False @@ -676,9 +691,9 @@ hIsClosed :: Handle -> IO Bool hIsClosed handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ return True @@ -700,9 +715,9 @@ hIsReadable :: Handle -> IO Bool hIsReadable handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hIsReadable" handle @@ -721,9 +736,9 @@ hIsWritable :: Handle -> IO Bool hIsWritable handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hIsWritable" handle @@ -765,9 +780,9 @@ hGetBuffering :: Handle -> IO BufferMode hGetBuffering handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hGetBuffering" handle @@ -787,9 +802,9 @@ hIsSeekable :: Handle -> IO Bool hIsSeekable handle = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hIsSeekable" handle @@ -799,10 +814,10 @@ hIsSeekable handle = AppendHandle -> do writeHandle handle handle_ return False - other -> do + _ -> do rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block writeHandle handle handle_ - case rc of + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hIsSeekable" @@ -827,16 +842,16 @@ hSetEcho handle on = do else withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hSetEcho" handle - other -> do - rc <- CCALL(setTerminalEcho) (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block + _ -> do + rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block writeHandle handle handle_ - if rc /= -1 + if rc /= ((-1)::Int) then return () else constructErrorAndFail "hSetEcho" @@ -848,16 +863,16 @@ hGetEcho handle = do else withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hGetEcho" handle - other -> do + _ -> do rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block writeHandle handle handle_ - case rc of + case (rc::Int) of 1 -> return True 0 -> return False _ -> constructErrorAndFail "hSetEcho" @@ -866,16 +881,16 @@ hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "hIsTerminalDevice" handle - other -> do + _ -> do rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block writeHandle handle handle_ - case rc of + case (rc::Int) of 1 -> return True 0 -> return False _ -> constructErrorAndFail "hIsTerminalDevice" @@ -909,7 +924,7 @@ hUngetChar handle c = wantReadableHandle "hLookAhead" handle $ \ handle_ -> do rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block writeHandle handle handle_ - if rc == (-1) + if rc == ((-1)::Int) then constructErrorAndFail "hUngetChar" else return () @@ -926,7 +941,7 @@ slurpFile fname = do handle <- openFile fname ReadMode sz <- hFileSize handle if sz > toInteger (maxBound::Int) then - fail (userError "slurpFile: file too big") + ioError (userError "slurpFile: file too big") else do let sz_i = fromInteger sz chunk <- CCALL(allocMemory__) (sz_i::Int) @@ -940,14 +955,14 @@ slurpFile fname = do rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block. writeHandle handle handle_ hClose handle - if rc < 0 + if rc < (0::Int) then constructErrorAndFail "slurpFile" else return (chunk, rc) #ifndef __HUGS__ /* Hugs' Prelude doesn't need this */ hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int hFillBufBA handle buf sz - | sz <= 0 = fail (IOError (Just handle) + | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBufBA" ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. @@ -960,14 +975,14 @@ hFillBufBA handle buf sz rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block. #endif writeHandle handle handle_ - if rc >= 0 + if rc >= (0::Int) then return rc else constructErrorAndFail "hFillBufBA" #endif hFillBuf :: Handle -> Addr -> Int -> IO Int hFillBuf handle buf sz - | sz <= 0 = fail (IOError (Just handle) + | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBuf" ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. @@ -992,18 +1007,18 @@ hPutBuf handle buf len = let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block. writeHandle handle handle_ - if rc == 0 + if rc == (0::Int) then return () else constructErrorAndFail "hPutBuf" -#ifndef __HUGS__ /* Another one Hugs doesn't provide */ +#ifndef __HUGS__ /* An_ one Hugs doesn't provide */ hPutBufBA :: Handle -> ByteArray Int -> Int -> IO () hPutBufBA handle buf len = wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do let fo = haFO__ handle_ rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block. writeHandle handle handle_ - if rc == 0 + if rc == (0::Int) then return () else constructErrorAndFail "hPutBuf" #endif @@ -1017,9 +1032,9 @@ getHandleFd :: Handle -> IO Int getHandleFd handle = do withHandle handle $ \ handle_ -> do case (haType__ handle_) of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle "getHandleFd" handle @@ -1053,7 +1068,7 @@ ioeGetErrorString (IOError _ iot _ str) = ioeGetFileName (IOError _ _ _ str) = case span (/=':') str of - (fs,[]) -> Nothing + (_,[]) -> Nothing (fs,_) -> Just fs \end{code} @@ -1066,9 +1081,9 @@ wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantReadableHandle fun handle act = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle fun handle @@ -1077,11 +1092,11 @@ wantReadableHandle fun handle act = ioe_closedHandle fun handle AppendHandle -> do writeHandle handle handle_ - fail not_readable_error + ioError not_readable_error WriteHandle -> do writeHandle handle handle_ - fail not_readable_error - other -> act handle_ + ioError not_readable_error + _ -> act handle_ where not_readable_error = IOError (Just handle) IllegalOperation fun @@ -1091,9 +1106,9 @@ wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantWriteableHandle fun handle act = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle fun handle @@ -1102,8 +1117,8 @@ wantWriteableHandle fun handle act = ioe_closedHandle fun handle ReadHandle -> do writeHandle handle handle_ - fail not_writeable_error - other -> act handle_ + ioError not_writeable_error + _ -> act handle_ where not_writeable_error = IOError (Just handle) IllegalOperation fun @@ -1113,9 +1128,9 @@ wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantSeekableHandle fun handle act = withHandle handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do + ErrorHandle theError -> do writeHandle handle handle_ - fail ioError + ioError theError ClosedHandle -> do writeHandle handle handle_ ioe_closedHandle fun handle @@ -1124,7 +1139,7 @@ wantSeekableHandle fun handle act = ioe_closedHandle fun handle AppendHandle -> do writeHandle handle handle_ - fail not_seekable_error + ioError not_seekable_error _ -> act handle_ where not_seekable_error = @@ -1139,7 +1154,7 @@ access to a closed file. \begin{code} ioe_closedHandle :: String -> Handle -> IO a -ioe_closedHandle fun h = fail (IOError (Just h) IllegalOperation fun "handle is closed") +ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed") \end{code} Internal helper functions for Concurrent Haskell implementation @@ -1180,7 +1195,8 @@ mayBlock fo act = do #endif -#ifdef __HUGS__ +-- #ifdef __HUGS__ +#if 1 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () -- Hugs does actually have the primops needed to implement these @@ -1215,55 +1231,55 @@ type FILE_OBJ = ForeignObj -- as passed into functions type FILE_OBJ = Addr #endif -foreign import stdcall "libHS_cbits.so" "setBuf" prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () -foreign import stdcall "libHS_cbits.so" "getBufSize" prim_getBufSize :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "inputReady" prim_inputReady :: FILE_OBJ -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "fileGetc" prim_fileGetc :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "fileLookAhead" prim_fileLookAhead :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "readBlock" prim_readBlock :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "readLine" prim_readLine :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "readChar" prim_readChar :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "writeFileObject" prim_writeFileObject :: FILE_OBJ -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "filePutc" prim_filePutc :: FILE_OBJ -> Char -> IO RC -foreign import stdcall "libHS_cbits.so" "getBufStart" prim_getBufStart :: FILE_OBJ -> Int -> IO Addr -foreign import stdcall "libHS_cbits.so" "getWriteableBuf" prim_getWriteableBuf :: FILE_OBJ -> IO Addr -foreign import stdcall "libHS_cbits.so" "getBufWPtr" prim_getBufWPtr :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "setBufWPtr" prim_setBufWPtr :: FILE_OBJ -> Int -> IO () -foreign import stdcall "libHS_cbits.so" "closeFile" prim_closeFile :: FILE_OBJ -> Flush -> IO RC -foreign import stdcall "libHS_cbits.so" "fileEOF" prim_fileEOF :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "setBuffering" prim_setBuffering :: FILE_OBJ -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "flushFile" prim_flushFile :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "getBufferMode" prim_getBufferMode :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "seekFile_int64" prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC -foreign import stdcall "libHS_cbits.so" "seekFileP" prim_seekFileP :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "setTerminalEcho" prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "getTerminalEcho" prim_getTerminalEcho :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "isTerminalDevice" prim_isTerminalDevice :: FILE_OBJ -> IO RC -foreign import stdcall "libHS_cbits.so" "setConnectedTo" prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () -foreign import stdcall "libHS_cbits.so" "ungetChar" prim_ungetChar :: FILE_OBJ -> Char -> IO RC -foreign import stdcall "libHS_cbits.so" "readChunk" prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "writeBuf" prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC -foreign import stdcall "libHS_cbits.so" "getFileFd" prim_getFileFd :: FILE_OBJ -> IO FD -foreign import stdcall "libHS_cbits.so" "fileSize_int64" prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC -foreign import stdcall "libHS_cbits.so" "getFilePosn" prim_getFilePosn :: FILE_OBJ -> IO Int -foreign import stdcall "libHS_cbits.so" "setFilePosn" prim_setFilePosn :: FILE_OBJ -> Int -> IO Int -foreign import stdcall "libHS_cbits.so" "getConnFileFd" prim_getConnFileFd :: FILE_OBJ -> IO FD -foreign import stdcall "libHS_cbits.so" "allocMemory__" prim_allocMemory__ :: Int -> IO Addr -foreign import stdcall "libHS_cbits.so" "getLock" prim_getLock :: FD -> Exclusive -> IO RC -foreign import stdcall "libHS_cbits.so" "openStdFile" prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr -foreign import stdcall "libHS_cbits.so" "openFile" prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr -foreign import stdcall "libHS_cbits.so" "freeFileObject" prim_freeFileObject :: FILE_OBJ -> IO () -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" prim_freeStdFileObject :: FILE_OBJ -> IO () -foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" const_BUFSIZ :: Int - -foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import stdcall "libHS_cbits.so" "getErrStr__" prim_getErrStr__ :: IO Addr -foreign import stdcall "libHS_cbits.so" "getErrNo__" prim_getErrNo__ :: IO Int -foreign import stdcall "libHS_cbits.so" "getErrType__" prim_getErrType__ :: IO Int +foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () +foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC +foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr +foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr +foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO () +foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC +foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC +foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC +foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () +foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC +foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC +foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD +foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC +foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int +foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int +foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD +foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr +foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC +foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr +foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr +foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO () +foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO () +foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int + +foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__" unsafe prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () +foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () +foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__" unsafe prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () +foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__" unsafe prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () + +foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr +foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int +foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int #endif \end{code} diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs index 5a70f93..32c2558 100644 --- a/ghc/lib/std/PrelIOBase.lhs +++ b/ghc/lib/std/PrelIOBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelIOBase.lhs,v 1.6 1998/12/02 13:27:03 simonm Exp $ +% $Id: PrelIOBase.lhs,v 1.7 1999/01/14 18:12:58 sof Exp $ % % (c) The AQUA Project, Glasgow University, 1994-1998 % @@ -20,13 +20,16 @@ import {-# SOURCE #-} PrelErr ( error ) import PrelST import PrelBase -import {-# SOURCE #-} PrelException ( fail ) +import {-# SOURCE #-} PrelException ( ioError ) import PrelST ( ST(..), STret(..) ) import PrelMaybe ( Maybe(..) ) import PrelAddr ( Addr(..), nullAddr ) import PrelPack ( unpackCString ) + +#if !defined(__CONCURRENT_HASKELL__) import PrelArr ( MutableVar, readVar ) #endif +#endif #ifdef __HUGS__ #define cat2(x,y) x/**/y @@ -60,10 +63,11 @@ implement IO exceptions. #ifndef __HUGS__ newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) unIO (IO a) = a instance Functor IO where - map f x = x >>= (return . f) + fmap f x = x >>= (return . f) instance Monad IO where {-# INLINE return #-} @@ -73,6 +77,7 @@ instance Monad IO where return x = IO $ \ s -> (# s, x #) m >>= k = bindIO m k + fail s = error s -- not ioError? -- not required but worth having around fixIO :: (a -> IO a) -> IO a @@ -181,7 +186,7 @@ data IOErrorType deriving (Eq) instance Show IOErrorType where - showsPrec d e = + showsPrec _ e = showString $ case e of AlreadyExists -> "already exists" @@ -201,6 +206,7 @@ instance Show IOErrorType where TimeExpired -> "timeout" UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! UserError _ -> "failed" + UnsupportedOperation -> "unsupported operation" EOF -> "end of file" \end{code} @@ -209,27 +215,35 @@ Predicates on IOError; little effort made on these so far... \begin{code} +isAlreadyExistsError :: IOError -> Bool isAlreadyExistsError (IOError _ AlreadyExists _ _) = True isAlreadyExistsError _ = False +isAlreadyInUseError :: IOError -> Bool isAlreadyInUseError (IOError _ ResourceBusy _ _) = True isAlreadyInUseError _ = False +isFullError :: IOError -> Bool isFullError (IOError _ ResourceExhausted _ _) = True isFullError _ = False +isEOFError :: IOError -> Bool isEOFError (IOError _ EOF _ _) = True isEOFError _ = False +isIllegalOperation :: IOError -> Bool isIllegalOperation (IOError _ IllegalOperation _ _) = True isIllegalOperation _ = False +isPermissionError :: IOError -> Bool isPermissionError (IOError _ PermissionDenied _ _) = True isPermissionError _ = False +isDoesNotExistError :: IOError -> Bool isDoesNotExistError (IOError _ NoSuchThing _ _) = True isDoesNotExistError _ = False +isUserError :: IOError -> Bool isUserError (IOError _ (UserError _) _ _) = True isUserError _ = False \end{code} @@ -274,12 +288,12 @@ used. constructErrorAndFail :: String -> IO a constructErrorAndFail call_site = constructError call_site >>= \ io_error -> - fail io_error + ioError io_error constructErrorAndFailWithInfo :: String -> String -> IO a constructErrorAndFailWithInfo call_site reason = constructErrorMsg call_site (Just reason) >>= \ io_error -> - fail io_error + ioError io_error \end{code} @@ -306,7 +320,7 @@ constructErrorMsg call_site reason = CCALL(getErrStr__) >>= \ str -> let iot = - case errtype of + case (errtype::Int) of ERR_ALREADYEXISTS -> AlreadyExists ERR_HARDWAREFAULT -> HardwareFault ERR_ILLEGALOPERATION -> IllegalOperation @@ -482,7 +496,7 @@ mkBuffer__ fo sz_in_bytes = do _ -> do chunk <- CCALL(allocMemory__) sz_in_bytes if chunk == nullAddr - then fail (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") + then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory") else return chunk CCALL(setBuf) fo chunk sz_in_bytes diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs index e3c83ba..9f10b65 100644 --- a/ghc/lib/std/PrelList.lhs +++ b/ghc/lib/std/PrelList.lhs @@ -12,13 +12,14 @@ The List data type and its operations module PrelList ( [] (..), - head, last, tail, init, null, length, (!!), + map, (++), filter, concat, + 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, + sum, product, maximum, minimum, concatMap, zip, zip3, zipWith, zipWith3, unzip, unzip3 ) where @@ -59,8 +60,8 @@ last [] = errorEmptyList "last" -- eliminate repeated cases last [] = errorEmptyList "last" last (x:xs) = last' x xs - where last' x [] = x - last' _ (x:xs) = last' x xs + where last' y [] = y + last' _ (y:ys) = last' y ys #endif init :: [a] -> [a] @@ -72,8 +73,8 @@ init [] = errorEmptyList "init" -- eliminate repeated cases init [] = errorEmptyList "init" init (x:xs) = init' x xs - where init' x [] = [] - init' x (y:xs) = x : init' y xs + where init' _ [] = [] + init' y (z:zs) = y : init' z zs #endif null :: [a] -> Bool @@ -95,6 +96,16 @@ length l = len l 0# len (_:xs) a# = len xs (a# +# 1#) #endif +-- filter, applied to a predicate and a list, returns the list of those +-- elements that satisfy the predicate; i.e., +-- filter p xs = [ x | x <- xs, p x] +filter :: (a -> Bool) -> [a] -> [a] +filter _pred [] = [] +filter pred (x:xs) + | pred x = x : filter pred xs + | otherwise = filter pred xs + + -- 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: @@ -108,7 +119,7 @@ length l = len l 0# -- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] foldl :: (a -> b -> a) -> a -> [b] -> a -foldl f z [] = z +foldl _ z [] = z foldl f z (x:xs) = foldl f (f z x) xs foldl1 :: (a -> a -> a) -> [a] -> a @@ -116,7 +127,7 @@ foldl1 f (x:xs) = foldl f x xs foldl1 _ [] = errorEmptyList "foldl1" scanl :: (a -> b -> a) -> a -> [b] -> [a] -scanl f q xs = q : (case xs of +scanl f q ls = q : (case ls of [] -> [] x:xs -> scanl f (f q x) xs) @@ -128,17 +139,17 @@ scanl1 _ [] = errorEmptyList "scanl1" -- above functions. foldr1 :: (a -> a -> a) -> [a] -> a -foldr1 f [x] = x +foldr1 _ [x] = x foldr1 f (x:xs) = f x (foldr1 f xs) foldr1 _ [] = errorEmptyList "foldr1" scanr :: (a -> b -> b) -> b -> [a] -> [b] -scanr f q0 [] = [q0] +scanr _ 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 _ [x] = [x] scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs scanr1 _ [] = errorEmptyList "scanr1" @@ -161,7 +172,8 @@ replicate n x = take n (repeat x) -- on infinite lists. cycle :: [a] -> [a] -cycle xs = xs' where xs' = xs ++ xs' +cycle [] = error "Prelude.cycle: empty list" +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 @@ -199,6 +211,7 @@ takeUInt n xs | n >=# 0# = take_unsafe_UInt n xs | otherwise = errorNegativeIdx "take" +take_unsafe_UInt :: Int# -> [b] -> [b] take_unsafe_UInt 0# _ = [] take_unsafe_UInt m ls = case ls of @@ -206,9 +219,9 @@ take_unsafe_UInt m ls = (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs drop :: Int -> [b] -> [b] -drop (I# n#) xs +drop (I# n#) ls | n# <# 0# = errorNegativeIdx "drop" - | otherwise = drop# n# xs + | otherwise = drop# n# ls where drop# :: Int# -> [a] -> [a] drop# 0# xs = xs @@ -216,9 +229,9 @@ drop (I# n#) xs drop# m# (_:xs) = drop# (m# -# 1#) xs splitAt :: Int -> [b] -> ([b], [b]) -splitAt (I# n#) xs +splitAt (I# n#) ls | n# <# 0# = errorNegativeIdx "splitAt" - | otherwise = splitAt# n# xs + | otherwise = splitAt# n# ls where splitAt# :: Int# -> [a] -> ([a], [a]) splitAt# 0# xs = ([], xs) @@ -230,7 +243,7 @@ splitAt (I# n#) xs #endif /* USE_REPORT_PRELUDE */ span, break :: (a -> Bool) -> [a] -> ([a],[a]) -span p xs@[] = (xs, xs) +span _ xs@[] = (xs, xs) span p xs@(x:xs') | p x = let (ys,zs) = span p xs' in (x:ys,zs) | otherwise = ([],xs) @@ -239,7 +252,7 @@ span p xs@(x:xs') break p = span (not . p) #else -- HBC version (stolen) -break p xs@[] = (xs, xs) +break _ xs@[] = (xs, xs) break p xs@(x:xs') | p x = ([],xs) | otherwise = let (ys,zs) = break p xs' in (x:ys,zs) @@ -278,9 +291,10 @@ any, all :: (a -> Bool) -> [a] -> Bool any p = or . map p all p = and . map p #else -any p [] = False +any _ [] = False any p (x:xs) = p x || any p xs -all p [] = True + +all _ [] = True all p (x:xs) = p x && all p xs #endif @@ -294,14 +308,14 @@ notElem x = all (/= x) elem _ [] = False elem x (y:ys) = x==y || elem x ys -notElem x [] = True +notElem _ [] = True notElem x (y:ys)= x /= y && notElem x ys #endif -- 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) +lookup _key [] = Nothing +lookup key ((x,y):xys) | key == x = Just y | otherwise = lookup key xys @@ -336,6 +350,11 @@ minimum xs = foldl1 min xs concatMap :: (a -> [b]) -> [a] -> [b] concatMap f = foldr ((++) . f) [] + +concat :: [[a]] -> [a] +concat [] = [] +concat ([]:xss) = concat xss +concat ((y:ys):xss) = y: (ys ++ concat xss) \end{code} @@ -444,11 +463,14 @@ Common up near identical calls to `error' to reduce the number constant strings created when compiled: \begin{code} +errorEmptyList :: String -> a errorEmptyList fun = error (prel_list_str ++ fun ++ ": empty list") +errorNegativeIdx :: String -> a errorNegativeIdx fun = error (prel_list_str ++ fun ++ ": negative index") -prel_list_str = "PreludeList." +prel_list_str :: String +prel_list_str = "Prelude." \end{code} diff --git a/ghc/lib/std/PrelMaybe.lhs b/ghc/lib/std/PrelMaybe.lhs index 974e5de..20de4cc 100644 --- a/ghc/lib/std/PrelMaybe.lhs +++ b/ghc/lib/std/PrelMaybe.lhs @@ -15,28 +15,23 @@ import PrelBase data Maybe a = Nothing | Just a deriving (Eq, Ord, Show {- Read -}) maybe :: b -> (a -> b) -> Maybe a -> b -maybe n f Nothing = n -maybe n f (Just x) = f x +maybe n _ Nothing = n +maybe _ f (Just x) = f x instance Functor Maybe where - map f Nothing = Nothing - map f (Just a) = Just (f a) + fmap _ Nothing = Nothing + fmap f (Just a) = Just (f a) instance Monad Maybe where (Just x) >>= k = k x - Nothing >>= k = Nothing + Nothing >>= _ = Nothing - (Just x) >> k = k - Nothing >> k = Nothing + (Just _) >> k = k + Nothing >> _ = Nothing return = Just + fail _ = Nothing -instance MonadZero Maybe where - zero = Nothing - -instance MonadPlus Maybe where - Nothing ++ ys = ys - xs ++ ys = xs \end{code} diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs index 0e1d3a2..b565a98 100644 --- a/ghc/lib/std/PrelNum.lhs +++ b/ghc/lib/std/PrelNum.lhs @@ -33,10 +33,10 @@ class (Real a, Enum a) => Integral a where 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 + n `quot` d = q where (q,_) = quotRem n d + n `rem` d = r where (_,r) = quotRem n d + n `div` d = q where (q,_) = divMod n d + n `mod` d = r where (_,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 @@ -46,6 +46,7 @@ class (Num a) => Fractional a where fromRational :: Rational -> a recip x = 1 / x + x / y = x * recip y class (Fractional a) => Floating a where pi :: a @@ -93,6 +94,8 @@ class (RealFrac a, Floating a) => RealFloat a where scaleFloat :: Int -> a -> a isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE :: a -> Bool + atan2 :: a -> a -> a + exponent x = if m == 0 then 0 else n + floatDigits x where (m,n) = decodeFloat x @@ -102,6 +105,20 @@ class (RealFrac a, Floating a) => RealFloat a where scaleFloat k x = encodeFloat m (n+k) where (m,n) = decodeFloat x + + atan2 y x + | x > 0 = atan (y/x) + | x == 0 && y > 0 = pi/2 + | x < 0 && y > 0 = pi + atan (y/x) + |(x <= 0 && y < 0) || + (x < 0 && isNegativeZero y) || + (isNegativeZero x && isNegativeZero y) + = -atan2 (-y) x + | y == 0 && (x < 0 || isNegativeZero x) + = pi -- must be after the previous test on zero y + | x==0 && y==0 = y -- must be after the other double zero tests + | otherwise = x + y -- x or y is a NaN, return a NaN (via +) + \end{code} %********************************************************* @@ -121,10 +138,10 @@ instance Integral Int where -- 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" + else error "Prelude.Integral{Int}.quot: divide by 0\n" a `rem` b = if b /= 0 then a `remInt` b - else error "Integral.Int.rem{PreludeCore}: divide by 0\n" + else error "Prelude.Integral{Int}.rem: 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 @@ -186,7 +203,7 @@ instance Num Integer where = case minusInteger# a1 s1 d1 a2 s2 d2 of (# a, s, d #) -> J# a s d negate (J# a s d) - = case negateInteger# a s d of (# a, s, d #) -> J# a s d + = case negateInteger# a s d of (# a1, s1, d1 #) -> J# a1 s1 d1 (*) (J# a1 s1 d1) (J# a2 s2 d2) = case timesInteger# a1 s1 d1 a2 s2 d2 of (# a, s, d #) -> J# a s d @@ -200,7 +217,7 @@ instance Num Integer where else case negateInteger# a1 s1 d1 of (# a, s, d #) -> J# a s d } - signum n@(J# a1 s1 d1) + signum (J# a1 s1 d1) = case 0 of { J# a2 s2 d2 -> let cmp = cmpInteger# a1 s1 d1 a2 s2 d2 @@ -237,24 +254,26 @@ instance Integral Integer where -- you get slightly better code if you let the compiler -- see them right here: n `quot` d = if d /= 0 then q else - error "Integral.Integer.quot{PreludeCore}: divide by 0\n" - where (q,r) = quotRem n d + error "Prelude.Integral{Integer}.quot: divide by 0\n" + where (q,_) = quotRem n d n `rem` d = if d /= 0 then r else - error "Integral.Integer.quot{PreludeCore}: divide by 0\n" - 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 + error "Prelude.Integral{Integer}.rem: divide by 0\n" + where (_,r) = quotRem n d + n `div` d = q where (q,_) = divMod n d + n `mod` d = r where (_,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 + succ x = x + 1 + pred x = x - 1 toEnum n = toInteger n fromEnum n = toInt n enumFrom n = n : enumFrom (n + 1) enumFromThen m n = en' m (n - m) - where en' m n = m : en' (m + n) n + where en' a b = a : en' (a + b) b enumFromTo n m = takeWhile (<= m) (enumFrom n) enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) (enumFromThen n m) @@ -263,34 +282,40 @@ instance Show Integer where showsPrec x = showSignedInteger x showList = showList__ (showsPrec 0) + instance Ix Integer where range (m,n) = [m..n] - index b@(m,n) i + index b@(m,_) i | inRange b i = fromInteger (i - m) - | otherwise = error "Integer.index: Index out of range." + | otherwise = indexIntegerError i b inRange (m,n) i = m <= i && i <= n +-- Sigh, really want to use helper function in Ix, but +-- module deps. are too painful. +{-# NOINLINE indexIntegerError #-} +indexIntegerError :: Integer -> (Integer,Integer) -> a +indexIntegerError i rng + = error (showString "Ix{Integer}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 rng) "") + showSignedInteger :: Int -> Integer -> ShowS showSignedInteger p n r - = -- from HBC version; support code follows - if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r - -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' q (chr (toInt r + (ord_0::Int)) : cs) - where - (q,r) = n `quotRem` 10 - + | n < 0 && p > 6 = '(':jtos n (')':r) + | otherwise = jtos n r + +jtos :: Integer -> String -> String +jtos i rs + | i < 0 = '-' : jtos' (-i) rs + | otherwise = jtos' i rs + where + jtos' :: Integer -> String -> String + jtos' n cs + | n < 10 = chr (fromInteger n + (ord_0::Int)) : cs + | otherwise = jtos' q (chr (toInt r + (ord_0::Int)) : cs) + where + (q,r) = n `quotRem` 10 \end{code} %********************************************************* @@ -313,7 +338,8 @@ It normalises a ratio by dividing both numerator and denominator by their greatest common divisor. \begin{code} -reduce x 0 = error "{Ratio.%}: zero denominator" +reduce :: (Integral a) => a -> a -> Ratio a +reduce _ 0 = error "{Ratio.%}: zero denominator" reduce x y = (x `quot` d) :% (y `quot` d) where d = gcd x y \end{code} @@ -321,9 +347,9 @@ reduce x y = (x `quot` d) :% (y `quot` d) \begin{code} x % y = reduce (x * signum y) (abs y) -numerator (x:%y) = x +numerator (x :% _) = x +denominator (_ :% y) = y -denominator (x:%y) = y \end{code} %********************************************************* @@ -343,8 +369,8 @@ odd = not . even 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) + where gcd' a 0 = a + gcd' a b = gcd' b (a `rem` b) {-# SPECIALISE lcm :: Int -> Int -> Int, @@ -359,12 +385,12 @@ lcm x y = abs ((x `quot` (gcd x y)) * y) Integer -> Int -> Integer, Int -> Int -> Int #-} (^) :: (Num a, Integral b) => a -> b -> a -x ^ 0 = 1 +_ ^ 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) + f a d y = g a d where + g b i | even i = g (b*b) (i `quot` 2) + | otherwise = f b (i-1) (b*y) _ ^ _ = error "Prelude.^: negative exponent" {- SPECIALISE (^^) :: @@ -373,14 +399,5 @@ _ ^ _ = error "Prelude.^: negative exponent" (^^) :: (Fractional a, Integral b) => a -> b -> a x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) -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" \end{code} diff --git a/ghc/lib/std/PrelNumExtra.lhs b/ghc/lib/std/PrelNumExtra.lhs index 20c4b8b..274b36e 100644 --- a/ghc/lib/std/PrelNumExtra.lhs +++ b/ghc/lib/std/PrelNumExtra.lhs @@ -21,10 +21,10 @@ import PrelNum import {-# SOURCE #-} PrelErr ( error ) import PrelList import PrelMaybe +import Maybe ( fromMaybe ) import PrelArr ( Array, array, (!) ) import PrelIOBase ( unsafePerformIO ) -import Ix ( Ix(..) ) import PrelCCall () -- we need the definitions of CCallable and -- CReturnable for the _ccall_s herein. \end{code} @@ -165,7 +165,7 @@ instance RealFloat Float where (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- .. isNegativeZero x = (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ... - isIEEE x = True + isIEEE _ = True \end{code} %********************************************************* @@ -293,8 +293,8 @@ instance RealFloat Double where floatDigits _ = DBL_MANT_DIG -- ditto floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto - decodeFloat (D# d#) - = case decodeDouble# d# of + decodeFloat (D# x#) + = case decodeDouble# x# of (# exp#, a#, s#, d# #) -> (J# a# s# d#, I# exp#) encodeFloat (J# a# s# d#) (I# e#) @@ -316,7 +316,7 @@ instance RealFloat Double where (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- .. isNegativeZero x = (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ... - isIEEE x = True + isIEEE _ = True instance Show Double where showsPrec x = showSigned showFloat x @@ -344,7 +344,7 @@ instance Show Double where fromIntegral :: (Integral a, Num b) => a -> b fromIntegral = fromInteger . toInteger -{- SPECIALIZE fromRealFrac :: +{- SPECIALIZE realToFrac :: Double -> Rational, Rational -> Double, Float -> Rational, @@ -354,8 +354,8 @@ fromIntegral = fromInteger . toInteger Double -> Float, Float -> Float, Float -> Double #-} -fromRealFrac :: (RealFrac a, Fractional b) => a -> b -fromRealFrac = fromRational . toRational +realToFrac :: (Real a, Fractional b) => a -> b +realToFrac = fromRational . toRational \end{code} %********************************************************* @@ -379,6 +379,8 @@ for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) \begin{code} instance Enum Float where + succ x = x + 1 + pred x = x - 1 toEnum = fromIntegral fromEnum = fromInteger . truncate -- may overflow enumFrom = numericEnumFrom @@ -386,6 +388,8 @@ instance Enum Float where enumFromThenTo = numericEnumFromThenTo instance Enum Double where + succ x = x + 1 + pred x = x - 1 toEnum = fromIntegral fromEnum = fromInteger . truncate -- may overflow enumFrom = numericEnumFrom @@ -414,7 +418,7 @@ the simplest rational between d'%r' and d%r. \begin{code} approxRational :: (RealFrac a) => a -> a -> Rational -approxRational x eps = simplest (x-eps) (x+eps) +approxRational rat eps = simplest (rat-eps) (rat+eps) where simplest x y | y < x = simplest y x | x == y = xr | x > 0 = simplest' n d n' d' @@ -450,7 +454,7 @@ instance (Integral a) => Num (Ratio a) where (x:%y) * (x':%y') = reduce (x * x') (y * y') negate (x:%y) = (-x) :% y abs (x:%y) = abs x :% y - signum (x:%y) = signum x :% 1 + signum (x:%_) = signum x :% 1 fromInteger x = fromInteger x :% 1 instance (Integral a) => Real (Ratio a) where @@ -466,6 +470,8 @@ instance (Integral a) => RealFrac (Ratio a) where where (q,r) = quotRem x y instance (Integral a) => Enum (Ratio a) where + succ x = x + 1 + pred x = x - 1 enumFrom = iterate ((+)1) enumFromThen n m = iterate ((+)(m-n)) n toEnum n = fromIntegral n :% 1 @@ -494,7 +500,8 @@ showRational n r = let (r', e) = normalize r in prR n r' e -startExpExp = 4 :: Int +startExpExp :: Int +startExpExp = 4 -- make sure 1 <= r < 10 normalize :: Rational -> (Rational, Int) @@ -503,15 +510,26 @@ normalize r = if r < 1 then 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 = + -- Invariant: x*10^e == original r + norm 0 x e = (x, e) + norm ee x 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 + in if x >= tn then norm ee (x/tn) (e+n) else norm (ee-1) x e +drop0 :: String -> String drop0 "" = "" -drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs)) +drop0 (c:cs) = c : fromMaybe [] (dropTrailing0s cs) --WAS (yuck): reverse (dropWhile (=='0') (reverse cs)) + where + dropTrailing0s [] = Nothing + dropTrailing0s ('0':xs) = + case dropTrailing0s xs of + Nothing -> Nothing + Just ls -> Just ('0':ls) + dropTrailing0s (x:xs) = + case dropTrailing0s xs of + Nothing -> Just [x] + Just ls -> Just (x:ls) prR :: Int -> Rational -> Int -> String prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment @@ -580,11 +598,11 @@ fromRat x = x' Now, here's Lennart's code. \begin{code} ---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 +fromRat :: (RealFloat a) => Rational -> a +fromRat x + | x == 0 = encodeFloat 0 0 -- Handle exceptional cases + | x < 0 = - fromRat' (-x) -- first. + | otherwise = fromRat' x -- Conversion process: -- Scale the rational number by the RealFloat base until @@ -600,8 +618,8 @@ fromRat' x = 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) + 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) @@ -609,25 +627,24 @@ fromRat' x = r -- 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) +scaleRat b minExp xMin xMax p x + | p <= minExp = (x, p) + | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b) + | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b) + | otherwise = (x, p) -- Exponentiation with a cache for the most common numbers. -minExpt = 0::Int -maxExpt = 1100::Int +minExpt, maxExpt :: Int +minExpt = 0 +maxExpt = 1100 + 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]] @@ -635,15 +652,18 @@ expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] -- 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 +integerLogBase b i + | i < b = 0 + | otherwise = doDiv (i `div` (b^l)) l + where -- 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 + l = 2 * integerLogBase (b*b) i + + doDiv :: Integer -> Int -> Int + doDiv x y + | x < b = y + | otherwise = doDiv (x `div` b) (y+1) + \end{code} %********************************************************* @@ -656,10 +676,11 @@ integerLogBase b i = --Exported from std library Numeric, defined here to --avoid mut. rec. between PrelNum and Numeric. 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 showPos p x + | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x)) + | otherwise = showPos x +showFloat :: (RealFloat a) => a -> ShowS showFloat x = showString (formatRealFloat FFGeneric Nothing x) -- These are the format types. This type is not exported. @@ -667,33 +688,27 @@ showFloat x = showString (formatRealFloat FFGeneric Nothing x) data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show) formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String -formatRealFloat fmt decs x = s +formatRealFloat fmt decs x + | isNaN x = "NaN" + | isInfinite x && x < 0 = if x < 0 then "-Infinity" else "Infinity" + | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x)) + | otherwise = doFmt fmt (floatToDigits (toInteger base) x) 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) = + + doFmt format (is, e) = let ds = map intToDigit is in - case fmt of + case format of FFGeneric -> - doFmt (if e <0 || e > 7 then FFExponent else FFFixed) + doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) (is,e) FFExponent -> case decs of Nothing -> let e' = if e==0 then 0 else e-1 in (case ds of - [d] -> d : ".0e" - (d:ds) -> d : '.' : ds ++ "e") ++ show e' + [d] -> d : ".0e" ++ show e' + (d:ds') -> d : '.' : ds' ++ "e") ++ show e' Just dec -> let dec' = max dec 1 in case is of @@ -701,9 +716,9 @@ formatRealFloat fmt decs x = s _ -> let (ei,is') = roundTo base (dec'+1) is - d:ds = map intToDigit (if ei > 0 then init is' else is') + (d:ds') = map intToDigit (if ei > 0 then init is' else is') in - d:'.':ds ++ 'e':show (e-1+ei) + d:'.':ds' ++ 'e':show (e-1+ei) FFFixed -> let mk0 ls = case ls of { "" -> "0" ; _ -> ls} @@ -711,13 +726,13 @@ formatRealFloat fmt decs x = s case decs of Nothing -> let - f 0 s ds = mk0 (reverse s) ++ '.':mk0 ds - f n s "" = f (n-1) ('0':s) "" - f n s (d:ds) = f (n-1) (d:s) ds + f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs + f n s "" = f (n-1) ('0':s) "" + f n s (r:rs) = f (n-1) (r:s) rs in f e "" ds Just dec -> - let dec' = max dec 1 in + let dec' = max dec 0 in if e >= 0 then let (ei,is') = roundTo base (dec' + e) is @@ -727,30 +742,27 @@ formatRealFloat fmt decs x = s else let (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is) - d:ds = map intToDigit (if ei > 0 then is' else 0:is') + d:ds' = map intToDigit (if ei > 0 then is' else 0:is') in - d : '.' : ds + d : '.' : ds' roundTo :: Int -> Int -> [Int] -> (Int,[Int]) roundTo base d is = - let - v = f d is - in - case v of - (0,is) -> v - (1,is) -> (1, 1:is) + case f d is of + x@(0,_) -> x + (1,xs) -> (1, 1:xs) 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) + f n [] = (0, replicate n 0) + f 0 (x:_) = (if x >= b2 then 1 else 0, []) + f n (i:xs) + | i' == base = (1,0:ds) + | otherwise = (0,i':ds) + where + (c,ds) = f (n-1) xs + i' = c + i -- -- Based on "Printing Floating-Point Numbers Quickly and Accurately" @@ -759,7 +771,8 @@ roundTo base d is = -- This function returns a list of digits (Ints in [0..base-1]) and an -- exponent. ---floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) floatToDigits _ 0 = ([0], 0) floatToDigits base x = let @@ -797,7 +810,8 @@ floatToDigits base x = else ceiling ((log (fromInteger (f+1)) + fromInt e * log (fromInteger b)) / - fromInt e * log (fromInteger b)) + log (fromInteger base)) +--WAS: fromInt e * log (fromInteger b)) fixup n = if n >= 0 then @@ -840,12 +854,16 @@ Definitions of the boxed PrimOps; these will be used in the case of partial applications, etc. \begin{code} +plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float 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 :: Float -> Float negateFloat (F# x) = F# (negateFloat# x) +gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool gtFloat (F# x) (F# y) = gtFloat# x y geFloat (F# x) (F# y) = geFloat# x y eqFloat (F# x) (F# y) = eqFloat# x y @@ -853,9 +871,16 @@ 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 :: Float -> Int float2Int (F# x) = I# (float2Int# x) + +int2Float :: Int -> Float int2Float (I# x) = F# (int2Float# x) +expFloat, logFloat, sqrtFloat :: Float -> Float +sinFloat, cosFloat, tanFloat :: Float -> Float +asinFloat, acosFloat, atanFloat :: Float -> Float +sinhFloat, coshFloat, tanhFloat :: Float -> Float expFloat (F# x) = F# (expFloat# x) logFloat (F# x) = F# (logFloat# x) sqrtFloat (F# x) = F# (sqrtFloat# x) @@ -869,17 +894,22 @@ sinhFloat (F# x) = F# (sinhFloat# x) coshFloat (F# x) = F# (coshFloat# x) tanhFloat (F# x) = F# (tanhFloat# x) +powerFloat :: Float -> Float -> Float 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, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double plusDouble (D# x) (D# y) = D# (x +## y) minusDouble (D# x) (D# y) = D# (x -## y) timesDouble (D# x) (D# y) = D# (x *## y) divideDouble (D# x) (D# y) = D# (x /## y) + +negateDouble :: Double -> Double negateDouble (D# x) = D# (negateDouble# x) +gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool gtDouble (D# x) (D# y) = x >## y geDouble (D# x) (D# y) = x >=## y eqDouble (D# x) (D# y) = x ==## y @@ -887,11 +917,21 @@ neDouble (D# x) (D# y) = x /=## y ltDouble (D# x) (D# y) = x <## y leDouble (D# x) (D# y) = x <=## y +double2Int :: Double -> Int double2Int (D# x) = I# (double2Int# x) + +int2Double :: Int -> Double int2Double (I# x) = D# (int2Double# x) + +double2Float :: Double -> Float double2Float (D# x) = F# (double2Float# x) +float2Double :: Float -> Double float2Double (F# x) = D# (float2Double# x) +expDouble, logDouble, sqrtDouble :: Double -> Double +sinDouble, cosDouble, tanDouble :: Double -> Double +asinDouble, acosDouble, atanDouble :: Double -> Double +sinhDouble, coshDouble, tanhDouble :: Double -> Double expDouble (D# x) = D# (expDouble# x) logDouble (D# x) = D# (logDouble# x) sqrtDouble (D# x) = D# (sqrtDouble# x) @@ -905,5 +945,6 @@ sinhDouble (D# x) = D# (sinhDouble# x) coshDouble (D# x) = D# (coshDouble# x) tanhDouble (D# x) = D# (tanhDouble# x) +powerDouble :: Double -> Double -> Double powerDouble (D# x) (D# y) = D# (x **## y) \end{code} diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs index 8f009cc..f126c56 100644 --- a/ghc/lib/std/PrelPack.lhs +++ b/ghc/lib/std/PrelPack.lhs @@ -106,8 +106,8 @@ unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest unpackNBytes# :: Addr# -> Int# -> [Char] -- This one is called by the compiler to unpack literal strings with NULs in them; rare. -- It's strict! -unpackNBytes# addr 0# = [] -unpackNBytes# addr len# = unpack [] (len# -# 1#) +unpackNBytes# _addr 0# = [] +unpackNBytes# addr len# = unpack [] (len# -# 1#) where unpack acc i# | i# <# 0# = acc @@ -119,8 +119,8 @@ unpackNBytesST# :: Addr# -> Int# -> ST s [Char] unpackNBytesST# addr# l# = unpackNBytesAccST# addr# l# [] unpackNBytesAccST# :: Addr# -> Int# -> [Char] -> ST s [Char] -unpackNBytesAccST# addr 0# rest = return rest -unpackNBytesAccST# addr len# rest = unpack rest (len# -# 1#) +unpackNBytesAccST# _addr 0# rest = return rest +unpackNBytesAccST# addr len# rest = unpack rest (len# -# 1#) where unpack acc i# | i# <# 0# = return acc @@ -167,8 +167,8 @@ unpackNBytesBA (ByteArray (l,u) bytes) i | otherwise = u-l+1 unpackNBytesBA# :: ByteArray# -> Int# -> [Char] -unpackNBytesBA# bytes 0# = [] -unpackNBytesBA# bytes len# = unpack [] (len# -# 1#) +unpackNBytesBA# _bytes 0# = [] +unpackNBytesBA# bytes len# = unpack [] (len# -# 1#) where unpack acc i# | i# <# 0# = acc @@ -200,7 +200,7 @@ packStringST str = packNBytesST len str packNBytesST :: Int -> [Char] -> ST s (ByteArray Int) -packNBytesST len@(I# length#) str = +packNBytesST (I# length#) str = {- allocate an array that will hold the string (not forgetting the NUL byte at the end) diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs index a4ad6a4..a4e394b 100644 --- a/ghc/lib/std/PrelRead.lhs +++ b/ghc/lib/std/PrelRead.lhs @@ -23,7 +23,7 @@ import Monad -- needed for readIO. import PrelIOBase ( IO, userError ) -import PrelException ( fail ) +import PrelException ( ioError ) \end{code} %********************************************************* @@ -72,16 +72,16 @@ read s = case read_s s of #ifndef NEW_READS_REP [x] -> x - [] -> error "PreludeText.read: no parse" - _ -> error "PreludeText.read: ambiguous parse" + [] -> error "Prelude.read: no parse" + _ -> error "Prelude.read: ambiguous parse" #else Just x -> x - Nothing -> error "PreludeText.read: no parse" + Nothing -> error "Prelude.read: no parse" #endif where - read_s s = do - (x,t) <- reads s - ("","") <- lex t + read_s str = do + (x,str1) <- reads str + ("","") <- lex str1 return x -- raises an exception instead of an error @@ -89,11 +89,11 @@ readIO :: Read a => String -> IO a readIO s = case (do { (x,t) <- reads s ; ("","") <- lex t ; return x }) of #ifndef NEW_READS_REP [x] -> return x - [] -> fail (userError "PreludeIO.readIO: no parse") - _ -> fail (userError "PreludeIO.readIO: ambiguous parse") + [] -> ioError (userError "Prelude.readIO: no parse") + _ -> ioError (userError "Prelude.readIO: ambiguous parse") #else Just x -> return x - Nothing -> fail (userError "PreludeIO.readIO: no parse") + Nothing -> ioError (userError "Prelude.readIO: no parse") #endif \end{code} @@ -173,35 +173,53 @@ lex (c:s) | isSingle c = return ([c],s) (nam,t) <- return (span isIdChar s) return (c:nam, t) | isDigit c = do - (ds,s) <- return (span isDigit s) - (fe,t) <- lexFracExp s + let + (pred, s', isDec) = + case s of + ('o':rs) -> (isOctDigit, rs, False) + ('O':rs) -> (isOctDigit, rs, False) + ('x':rs) -> (isHexDigit, rs, False) + ('X':rs) -> (isHexDigit, rs, False) + _ -> (isDigit, s, True) + + (ds,s) <- return (span pred s') + (fe,t) <- lexFracExp isDec s return (c:ds++fe,t) - | otherwise = zero -- bad character + | otherwise = mzero -- bad character where isSingle c = c `elem` ",;()[]{}_`" isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" - isIdChar c = isAlphanum c || c `elem` "_'" + isIdChar c = isAlphaNum c || c `elem` "_'" - lexFracExp ('.':cs) = do + lexFracExp True ('.':cs) = do (ds,t) <- lex0Digits cs (e,u) <- lexExp t return ('.':ds++e,u) - lexFracExp s = return ("",s) + lexFracExp _ s = return ("",s) lexExp (e:s) | e `elem` "eE" = (do (c:t) <- return s guard (c `elem` "+-") - (ds,u) <- lexDigits t + (ds,u) <- lexDecDigits t return (e:c:ds,u)) ++ (do - (ds,t) <- lexDigits s + (ds,t) <- lexDecDigits s return (e:ds,t)) lexExp s = return ("",s) -lexDigits :: ReadS String -lexDigits = nonnull isDigit +lexDigits :: ReadS String +lexDigits = lexDecDigits + +lexDecDigits :: ReadS String +lexDecDigits = nonnull isDigit + +lexOctDigits :: ReadS String +lexOctDigits = nonnull isOctDigit + +lexHexDigits :: ReadS String +lexHexDigits = nonnull isHexDigit -- 0 or more digits lex0Digits :: ReadS String @@ -216,13 +234,26 @@ lexLitChar :: ReadS String lexLitChar ('\\':s) = do (esc,t) <- lexEsc s return ('\\':esc, t) - where - lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = return ([c],s) - lexEsc s@(d:_) | isDigit d = lexDigits s - lexEsc _ = zero + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = return ([c],s) + lexEsc s@(d:_) | isDigit d = lexDecDigits s + lexEsc ('o':d:s) | isDigit d = lexOctDigits (d:s) + lexEsc ('O':d:s) | isDigit d = lexOctDigits (d:s) + lexEsc ('x':d:s) | isDigit d = lexHexDigits (d:s) + lexEsc ('X':d:s) | isDigit d = lexHexDigits (d:s) + lexEsc ('^':c:s) | '@' <= c && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report. + lexEsc s@(c:_) | isUpper c = fromAsciiLab s + lexEsc _ = mzero + + fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) && + [x,y,z] `elem` asciiTab = return ([x,y,z], ls) + fromAsciiLab (x:y:ls) | isUpper y && + [x,y] `elem` asciiTab = return ([x,y], ls) + fromAsciiLab _ = mzero + lexLitChar (c:s) = return ([c],s) -lexLitChar "" = zero +lexLitChar "" = mzero \end{code} %********************************************************* @@ -233,10 +264,10 @@ lexLitChar "" = zero \begin{code} instance Read Char where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> do ('\'':s,t) <- lex r - (c,_) <- readLitChar s + (c,"\'") <- readLitChar s return (c,t)) readList = readParen False (\r -> do @@ -251,7 +282,7 @@ instance Read Char where return (c:cs,u) instance Read Bool where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> lex r >>= \ lr -> (do { ("True", rest) <- return lr ; return (True, rest) }) ++ @@ -259,7 +290,7 @@ instance Read Bool where instance Read Ordering where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> lex r >>= \ lr -> (do { ("LT", rest) <- return lr ; return (LT, rest) }) ++ @@ -267,7 +298,7 @@ instance Read Ordering where (do { ("GT", rest) <- return lr ; return (GT, rest) })) instance Read a => Read (Maybe a) where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> lex r >>= \ lr -> (do { ("Nothing", rest) <- return lr ; return (Nothing, rest)}) ++ @@ -277,7 +308,7 @@ instance Read a => Read (Maybe a) where return (Just x, rest2))) instance (Read a, Read b) => Read (Either a b) where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> lex r >>= \ lr -> (do @@ -290,16 +321,16 @@ instance (Read a, Read b) => Read (Either a b) where return (Right x, rest2))) instance Read Int where - readsPrec p x = readSigned readDec x + readsPrec _ x = readSigned readDec x instance Read Integer where - readsPrec p x = readSigned readDec x + readsPrec _ x = readSigned readDec x instance Read Float where - readsPrec p x = readSigned readFloat x + readsPrec _ x = readSigned readFloat x instance Read Double where - readsPrec p x = readSigned readFloat x + readsPrec _ x = readSigned readFloat x instance (Integral a, Read a) => Read (Ratio a) where readsPrec p = readParen (p > ratio_prec) @@ -310,17 +341,17 @@ instance (Integral a, Read a) => Read (Ratio a) where return (x%y,u)) instance (Read a) => Read [a] where - readsPrec p = readList + readsPrec _ = readList instance Read () where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> do ("(",s) <- lex r (")",t) <- lex s return ((),t)) instance (Read a, Read b) => Read (a,b) where - readsPrec p = readParen False + readsPrec _ = readParen False (\r -> do ("(",s) <- lex r (x,t) <- readsPrec 0 s @@ -330,7 +361,7 @@ instance (Read a, Read b) => Read (a,b) where return ((x,y), w)) instance (Read a, Read b, Read c) => Read (a, b, c) where - readsPrec p = readParen False + readsPrec _ = readParen False (\a -> do ("(",b) <- lex a (x,c) <- readsPrec 0 b @@ -342,7 +373,7 @@ instance (Read a, Read b, Read c) => Read (a, b, c) where return ((x,y,z), h)) instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where - readsPrec p = readParen False + readsPrec _ = readParen False (\a -> do ("(",b) <- lex a (w,c) <- readsPrec 0 b @@ -356,7 +387,7 @@ instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where return ((w,x,y,z), i)) instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where - readsPrec p = readParen False + readsPrec _ = readParen False (\a -> do ("(",b) <- lex a (v,c) <- readsPrec 0 b @@ -382,6 +413,7 @@ instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where \begin{code} readLitChar :: ReadS Char +readLitChar [] = mzero readLitChar ('\\':s) = readEsc s where readEsc ('a':s) = return ('\a',s) @@ -412,8 +444,8 @@ readLitChar ('\\':s) = readEsc s in case [(c,s') | (c, mne) <- table, ([],s') <- [match mne s]] of (pr:_) -> return pr - [] -> zero - readEsc _ = zero + [] -> mzero + readEsc _ = mzero readLitChar (c:s) = return (c,s) @@ -505,7 +537,7 @@ readRational r = return (1/0,t) ) where readFix r = do - (ds,s) <- lexDigits r + (ds,s) <- lexDecDigits r (ds',t) <- lexDotDigits s return (read (ds++ds'), length ds', t) diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs index 916bc66..6addc5c 100644 --- a/ghc/lib/std/PrelST.lhs +++ b/ghc/lib/std/PrelST.lhs @@ -26,7 +26,7 @@ too many people got bitten by space leaks when it was lazy. newtype ST s a = ST (State# s -> (# State# s, a #)) instance Functor (ST s) where - map f (ST m) = ST $ \ s -> + fmap f (ST m) = ST $ \ s -> case (m s) of { (# new_s, r #) -> (# new_s, f r #) } @@ -55,7 +55,7 @@ fixST k = ST $ \ s -> let ans = liftST (k r) s STret _ r = ans in - case ans of STret s' r -> (# s', r #) + case ans of STret s' x -> (# s', x #) {-# NOINLINE unsafeInterleaveST #-} unsafeInterleaveST :: ST s a -> ST s a @@ -67,7 +67,7 @@ unsafeInterleaveST (ST m) = ST ( \ s -> ) instance Show (ST s a) where - showsPrec p f = showString "<>" + showsPrec _ _ = showString "<>" showList = showList__ (showsPrec 0) \end{code} diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs index 64307ff..c375eb7 100644 --- a/ghc/lib/std/PrelTup.lhs +++ b/ghc/lib/std/PrelTup.lhs @@ -86,18 +86,18 @@ data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r \begin{code} instance (Show a, Show b) => Show (a,b) where - showsPrec p (x,y) = showChar '(' . shows x . showChar ',' . + showsPrec _ (x,y) = showChar '(' . shows x . showChar ',' . 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 . showChar ',' . + showsPrec _ (x,y,z) = showChar '(' . showsPrec 0 x . showChar ',' . showsPrec 0 y . showChar ',' . 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 . showChar ',' . + showsPrec _ (w,x,y,z) = showChar '(' . showsPrec 0 w . showChar ',' . showsPrec 0 x . showChar ',' . showsPrec 0 y . showChar ',' . showsPrec 0 z . showChar ')' @@ -105,7 +105,7 @@ instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where 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 . showChar ',' . + showsPrec _ (v,w,x,y,z) = showChar '(' . showsPrec 0 v . showChar ',' . showsPrec 0 w . showChar ',' . showsPrec 0 x . showChar ',' . showsPrec 0 y . showChar ',' . @@ -122,10 +122,10 @@ instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where \begin{code} fst :: (a,b) -> a -fst (x,y) = x +fst (x,_) = x snd :: (a,b) -> b -snd (x,y) = y +snd (_,y) = y -- curry converts an uncurried function to a curried function; -- uncurry converts a curried function to a function on pairs. diff --git a/ghc/lib/std/PrelWeak.lhs b/ghc/lib/std/PrelWeak.lhs index 7d008a4..cbe510a 100644 --- a/ghc/lib/std/PrelWeak.lhs +++ b/ghc/lib/std/PrelWeak.lhs @@ -23,15 +23,15 @@ mkWeak :: k -- key -> IO (Weak v) -- weak pointer mkWeak key val finaliser = IO $ \s -> - case mkWeak# key val finaliser s of { (# s, w #) -> - (# s, Weak w #) } + case mkWeak# key val finaliser s of { (# s1, w #) -> + (# s1, Weak w #) } deRefWeak :: Weak v -> IO (Maybe v) deRefWeak (Weak w) = IO $ \s -> case deRefWeak# w s of - (# s, flag, w #) -> case flag of - 0# -> (# s, Nothing #) - _ -> (# s, Just w #) + (# s1, flag, p #) -> case flag of + 0# -> (# s1, Nothing #) + _ -> (# s1, Just p #) mkWeakPtr :: k -> IO () -> IO (Weak k) mkWeakPtr key finaliser = mkWeak key key finaliser diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs index 166ee8e..1b9c8e6 100644 --- a/ghc/lib/std/Prelude.lhs +++ b/ghc/lib/std/Prelude.lhs @@ -9,59 +9,59 @@ module Prelude ( -- Everything from these modules module PrelList, - module PrelTup, - - -- From PrelBase - (->), - Eq(..), - Ord(..), Ordering(..), - Bounded(..), - Enum(..), succ, pred, - Show(..), ShowS, shows, show, showChar, showString, showParen, - seq, strict, - Bool(..), (&&), (||), not, otherwise, - Char, String, Int, Integer, Float, Double, Void, - Maybe(..), maybe, - Either(..), either, - ()(..), -- The unit type - + -- Everything corresponding to the Report's PreludeText + ReadS, ShowS, + Read(readsPrec, readList), + Show(showsPrec, showList, show), + reads, shows, read, lex, + showChar, showString, readParen, showParen, - id, const, (.), flip, ($), until, asTypeOf, undefined, - - -- From Error - error, - - -- From Monad - Functor(..), Monad(..), MonadZero(..), MonadPlus(..), - accumulate, sequence, mapM, mapM_, guard, filter, concat, applyM, - - -- From PrelRead - ReadS, Read(readsPrec, readList), - reads, read, lex, readParen, - - -- From IO - IO, FilePath, IOError, - fail, userError, catch, + -- Everything corresponding to the Report's PreludeIO + FilePath, IOError, + ioError, userError, catch, putChar, putStr, putStrLn, print, getChar, getLine, getContents, interact, readFile, writeFile, appendFile, readIO, readLn, - -- From PrelNum + Bool(..), + Maybe(..), + Either(..), + Ordering(..), + Char, String, Int, Integer, Float, Double, IO, Ratio, Rational, - (%), numerator, denominator, approxRational, - + []((:), []), + + module PrelTup, + -- Includes tuple types + fst, snd, curry, uncurry + ()(..), -- The unit type + (->), -- functions + + Eq(..), + Ord(..), + Enum(..), + Bounded(..), Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt{-glaExt-}), - Real(toRational), + Real(..), 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), + Fractional(..), + Floating(..), + RealFrac(..), + RealFloat(..), + + -- From Monad + Monad(..), + Functor(..), + mapM, mapM_, sequence, sequence_, (=<<), + + maybe, either, + (&&), (||), not, otherwise, subtract, even, odd, gcd, lcm, (^), (^^), - fromIntegral, fromRealFrac, atan2 + fromIntegral, realToFrac, + --exported by PrelTup: fst, snd, curry, uncurry, + id, const, (.), flip, ($), until, + asTypeOf, error, undefined, + seq, ($!) + ) where import PrelBase @@ -79,11 +79,10 @@ import Maybe import PrelErr ( error ) import IO --- These can't conveniently be defined in PrelBase because they use numbers, --- or I/O, so here's a convenient place to do them. +infixr 0 $! -strict :: (a -> b) -> a -> b -strict f x = x `seq` f x +($!) :: (a -> b) -> a -> b +f $! x = x `seq` f x -- It is expected that compilers will recognize this and insert error -- messages which are more appropriate to the context in which undefined diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs index 511ffe4..a1a7e22 100644 --- a/ghc/lib/std/Random.lhs +++ b/ghc/lib/std/Random.lhs @@ -1,5 +1,7 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-99 +% -This module implements a (good) random number generator. The June 1988 (v31 #6) issue of the Communications of the ACM has an article by Pierre L'Ecuyer called, "Efficient and Portable Combined @@ -8,51 +10,193 @@ L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18. Transliterator: Lennart Augustsson +sof 1/99 - code brought (kicking and screaming) into the new Random +world.. + \begin{code} module Random ( - random, - randomIO - ) where + RandomGen(next, split) + , StdGen + , mkStdGen + , Random ( random, randomR, + randoms, randomRs, + randomIO, randomRIO ) + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + ) where import CPUTime (getCPUTime) +import PrelST +import PrelRead +import PrelIOBase +import PrelNumExtra ( float2Double, double2Float ) +import PrelBase +import PrelArr +import Char ( isSpace, chr, ord ) import Time (getClockTime, ClockTime(..)) -randomIO :: (Integer, Integer) -> IO [Integer] -randomIO lh = do +\end{code} + +\begin{code} +class RandomGen g where + next :: g -> (Int, g) + split :: g -> (g, g) + +\end{code} + +\begin{code} +data StdGen + = StdGen Int Int + +instance RandomGen StdGen where + next = rand1 + split = splitStdGen + +instance Show StdGen where + showsPrec p (StdGen s1 s2) = + showSignedInt p s1 . + showSpace . + showSignedInt p s2 + +instance Read StdGen where + readsPrec p = \ r -> + case try_read r of + r@[_] -> r + _ -> [(unsafePerformIO mkStdRNG,r)] -- because it shouldn't ever fail. + where + try_read r = do + (s1, r1) <- readDec (dropWhile isSpace r) + (s2, r2) <- readDec (dropWhile isSpace r1) + return (StdGen s1 s2, r2) + +\end{code} + +\begin{code} +mkStdGen :: Int -> StdGen -- why not Integer ? +mkStdGen s + | s < 0 = mkStdGen (-s) + | otherwise = StdGen (s1+1) (s2+1) + where + (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + +createStdGen :: Integer -> StdGen +createStdGen s + | s < 0 = createStdGen (-s) + | otherwise = StdGen (toInt (s1+1)) (toInt (s2+1)) + where + (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + +\end{code} + +\begin{code} + +-- Q: do all of these merit class membership? +class Random a where + randomR :: RandomGen g => (a,a) -> g -> (a,g) + random :: RandomGen g => g -> (a, g) + + randomRs :: RandomGen g => (a,a) -> g -> [a] + randoms :: RandomGen g => g -> [a] + + randomRIO :: (a,a) -> IO a + randomIO :: IO a + + randoms g = x : randoms g' where (x,g') = random g + randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g + + randomIO = getStdRandom random + randomRIO range = getStdRandom (randomR range) + +\end{code} + +\begin{code} +instance Random Int where + randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g + random g = randomR (minBound,maxBound) g + +instance Random Char where + randomR (a,b) g = + case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of + (x,g) -> (chr x, g) + random g = randomR (minBound,maxBound) g + +instance Random Bool where + randomR (a,b) g = + case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of + (x, g) -> (int2Bool x, g) + where + bool2Int False = 0 + bool2Int True = 1 + + int2Bool 0 = False + int2Bool _ = True + + random g = randomR (minBound,maxBound) g + +instance Random Integer where + randomR ival g = randomIvalInteger ival g + random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g + +instance Random Double where + randomR ival g = randomIvalDouble ival id g + random g = randomR (0::Double,1) g + +-- hah, so you thought you were saving cycles by using Float? +instance Random Float where + randomR (a,b) g = randomIvalDouble (float2Double a, float2Double b) double2Float g + random g = randomIvalDouble (0::Double,1) double2Float g + +\end{code} + + +\begin{code} +mkStdRNG :: IO StdGen +mkStdRNG = do ct <- getCPUTime (TOD sec _) <- getClockTime - return (random lh (toInteger sec * 12345 + ct)) - -random :: (Integer, Integer) -> Integer -> [Integer] -random (l, h) s = - if l > h then error "Random.random: Empty interval" else - if s < 0 then random (l, h) (-s) else - let (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - k = h-l + 1 - b = 2147483561 - n = iLogBase b k - f is = let (xs, is') = splitAt n is - in foldr (\ i r -> fromInt i + r * b) 0 xs `mod` k + l : f is' - in f (randomInts (toInt (s1+1)) (toInt (s2+1))) + return (createStdGen (sec * 12345 + ct)) + +randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) +randomIvalInteger (l,h) rng + | l > h = randomIvalInteger (h,l) rng + | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (v `mod` (k+1)), rng') + where + k = h - l + 1 + b = 2147483561 + n = iLogBase b k + + f 0 acc g = (acc, g) + f n acc g = + let + (x,g') = next g + in + f (n-1) (fromInt x + acc * b) g' +randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) +randomIvalDouble (l,h) fromDouble rng + | l > h = randomIvalDouble (h,l) fromDouble rng + | otherwise = + case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of + (x, rng') -> + let + scaled_x = + fromDouble l + + fromDouble (h-l) * + (fromIntegral (x::Int) * 4.6566130638969828e-10) + -- magic number stolen from old HBC code (Random.randomDoubles.) + in + (scaled_x, rng') + +iLogBase :: Integer -> Integer -> Integer iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) --- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate --- an infinite list of random Ints. -randomInts :: Int -> Int -> [Int] -randomInts s1 s2 = - if 1 <= s1 && s1 <= 2147483562 then - if 1 <= s2 && s2 <= 2147483398 then - rands s1 s2 - else - error "randomInts: Bad second seed." - else - error "randomInts: Bad first seed." - -rands :: Int -> Int -> [Int] -rands s1 s2 = z' : rands s1'' s2'' +rand1 :: StdGen -> (Int, StdGen) +rand1 (StdGen s1 s2) = (z', StdGen s1'' s2'') where z' = if z < 1 then z + 2147483562 else z z = s1'' - s2'' @@ -63,5 +207,47 @@ rands s1 s2 = z' : rands s1'' s2'' k' = s2 `quot` 52774 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' + +splitStdGen :: StdGen -> (StdGen, StdGen) +splitStdGen std@(StdGen s1 s2) = (std, StdGen new_s1 new_s2) + where + -- simple in the extreme.. + new_s1 + | s1 == 2147483562 = 1 + | otherwise = s1 + 1 + + new_s2 + | s2 == 1 = 2147483398 + | otherwise = s2 - 1 + + \end{code} + + +\begin{code} +global_rng :: MutableVar RealWorld StdGen +global_rng = unsafePerformIO $ do + rng <- mkStdRNG + stToIO (newVar rng) + +setStdGen :: StdGen -> IO () +setStdGen sgen = stToIO (writeVar global_rng sgen) + +getStdGen :: IO StdGen +getStdGen = stToIO (readVar global_rng) + +newStdGen :: IO StdGen +newStdGen = do + rng <- getStdGen + let (a,b) = split rng + setStdGen a + return b + +getStdRandom :: (StdGen -> (a,StdGen)) -> IO a +getStdRandom f = do + rng <- getStdGen + let (v, new_rng) = f rng + setStdGen new_rng + return v +\end{code} diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs index 02e32e3..7c8107f 100644 --- a/ghc/lib/std/Ratio.lhs +++ b/ghc/lib/std/Ratio.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[Ratio]{Module @Ratio@} @@ -9,12 +9,29 @@ Standard functions on rational numbers \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module Ratio ( - Ratio, Rational, (%), numerator, denominator, approxRational +module Ratio + ( Ratio + , Rational + , (%) -- :: (Integral a) => a -> a -> Ratio a + , numerator -- :: (Integral a) => Ratio a -> a + , denominator -- :: (Integral a) => Ratio a -> a + , approxRational -- :: (RealFrac a) => a -> a -> Rational + + -- Ratio instances: + -- (Integral a) => Eq (Ratio a) + -- (Integral a) => Ord (Ratio a) + -- (Integral a) => Num (Ratio a) + -- (Integral a) => Real (Ratio a) + -- (Integral a) => Fractional (Ratio a) + -- (Integral a) => RealFrac (Ratio a) + -- (Integral a) => Enum (Ratio a) + -- (Read a, Integral a) => Read (Ratio a) + -- (Integral a) => Show (Ratio a) + -- + -- Implementation checked wrt. Haskell 98 lib report, 1/99. + ) where import PrelNum import PrelNumExtra \end{code} - - diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs index 0aed69e..f94ee48 100644 --- a/ghc/lib/std/System.lhs +++ b/ghc/lib/std/System.lhs @@ -1,14 +1,20 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1999 % \section[System]{Module @System@} \begin{code} {-# OPTIONS -#include "cbits/stgio.h" #-} -module System ( - ExitCode(ExitSuccess,ExitFailure), - getArgs, getProgName, getEnv, system, exitWith +module System + ( + ExitCode(ExitSuccess,ExitFailure) + , getArgs -- :: IO [String] + , getProgName -- :: IO String + , getEnv -- :: String -> IO String + , system -- :: String -> IO ExitCode + , exitWith -- :: ExitCode -> IO a + , exitFailure -- :: IO a ) where #ifdef __HUGS__ @@ -21,8 +27,17 @@ unpackCString = unsafeUnpackCString #else import Prelude import PrelAddr -import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo ) -import PrelPack ( unpackCString ) +import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFailWithInfo, stToIO ) +import PrelPack ( unpackCString, unpackCStringST, packString ) +import PrelArr ( ByteArray ) + +type PrimByteArray = ByteArray Int + +primUnpackCString :: Addr -> IO String +primUnpackCString s = stToIO ( unpackCStringST s ) + +primPackString :: String -> PrimByteArray +primPackString s = packString s #endif \end{code} @@ -46,44 +61,23 @@ data ExitCode = ExitSuccess | ExitFailure Int \end{code} - -%********************************************************* -%* * -\subsection{Other functions} -%* * -%********************************************************* - -\begin{code} -getArgs :: IO [String] -getProgName :: IO String -getEnv :: String -> IO String -system :: String -> IO ExitCode -exitWith :: ExitCode -> IO a -\end{code} - Computation $getArgs$ returns a list of the program's command line arguments (not including the program name). \begin{code} -#ifdef __HUGS__ -foreign import stdcall "libHS_cbits.so" "get_prog_argv" primArgv :: Addr -foreign import stdcall "libHS_cbits.so" "get_prog_argc" primArgc :: Int - +getArgs :: IO [String] getArgs = return (unpackArgv primArgv primArgc) -#else -getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int)) -#endif + +foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr +foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int \end{code} Computation $getProgName$ returns the name of the program as it was invoked. \begin{code} -#ifdef __HUGS__ +getProgName :: IO String getProgName = return (unpackProgName primArgv) -#else -getProgName = return (unpackProgName ``prog_argv'') -#endif \end{code} Computation $getEnv var$ returns the value @@ -96,23 +90,15 @@ The environment variable does not exist. \end{itemize} \begin{code} -#ifdef __HUGS__ -foreign import stdcall "libHS_cbits.so" "getenv" primGetEnv :: PrimByteArray -> IO Addr - +getEnv :: String -> IO String getEnv name = do litstring <- primGetEnv (primPackString name) if litstring /= nullAddr then primUnpackCString litstring - else fail (IOError Nothing NoSuchThing "getEnv" + else ioError (IOError Nothing NoSuchThing "getEnv" ("environment variable: " ++ name)) -#else -getEnv name = do - litstring <- _ccall_ getenv name - if litstring /= ``NULL'' - then return (unpackCString litstring) - else fail (IOError Nothing NoSuchThing "getEnv" - ("environment variable: " ++ name)) -#endif + +foreign import ccall "libHS_cbits.so" "getenv" primGetEnv :: PrimByteArray -> IO Addr \end{code} Computation $system cmd$ returns the exit code @@ -129,9 +115,8 @@ The implementation does not support system calls. \end{itemize} \begin{code} -#ifdef __HUGS__ -foreign import stdcall "libHS_cbits.so" "systemCmd" primSystem :: PrimByteArray -> IO Int -system "" = fail (IOError Nothing InvalidArgument "system" "null command") +system :: String -> IO ExitCode +system "" = ioError (IOError Nothing InvalidArgument "system" "null command") system cmd = do status <- primSystem (primPackString cmd) case status of @@ -139,45 +124,28 @@ system cmd = do -1 -> constructErrorAndFailWithInfo "system" cmd n -> return (ExitFailure n) -#else -system "" = fail (IOError Nothing InvalidArgument "system" "null command") -system cmd = do - status <- _ccall_ systemCmd cmd - case status of - 0 -> return ExitSuccess - -1 -> constructErrorAndFailWithInfo "system" cmd - n -> return (ExitFailure n) -#endif +foreign import ccall "libHS_cbits.so" "systemCmd" primSystem :: PrimByteArray -> IO Int \end{code} -Computation $exitWith code$ terminates the -program, returning {\em code} to the program's caller. +@exitWith code@ terminates the program, returning {\em code} to the program's caller. Before it terminates, any open or semi-closed handles are first closed. \begin{code} -#ifdef __HUGS__ -foreign import stdcall "libHS_cbits.so" "exit" primExit :: Int -> IO () - +exitWith :: ExitCode -> IO a exitWith ExitSuccess = do primExit 0 - fail (IOError Nothing OtherError "exitWith" "exit should not return") + ioError (IOError Nothing OtherError "exitWith" "exit should not return") exitWith (ExitFailure n) - | n == 0 = fail (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") + | n == 0 = ioError (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") | otherwise = do primExit n - fail (IOError Nothing OtherError "exitWith" "exit should not return") -#else -exitWith ExitSuccess = do - _ccall_ exit (0::Int) - fail (IOError Nothing OtherError "exitWith" "exit should not return") + ioError (IOError Nothing OtherError "exitWith" "exit should not return") -exitWith (ExitFailure n) - | n == 0 = fail (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0") - | otherwise = do - _ccall_ exit n - fail (IOError Nothing OtherError "exitWith" "exit should not return") -#endif +foreign import ccall "libHS_cbits.so" "exit" primExit :: Int -> IO () + +exitFailure :: IO a +exitFailure = exitWith (ExitFailure 1) \end{code} @@ -209,7 +177,7 @@ unpackProgName argv where -- re-start accumulating at every '/' de_slash :: String -> String -> String - de_slash acc [] = reverse acc - de_slash acc ('/':xs) = de_slash [] xs - de_slash acc (x:xs) = de_slash (x:acc) xs + de_slash acc [] = reverse acc + de_slash _acc ('/':xs) = de_slash [] xs + de_slash acc (x:xs) = de_slash (x:acc) xs \end{code} diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs index f002bcb..b4adb21 100644 --- a/ghc/lib/std/Time.lhs +++ b/ghc/lib/std/Time.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1995-97 +% (c) The GRASP/AQUA Project, Glasgow University, 1995-99 % \section[Time]{Haskell 1.4 Time of Day Library} @@ -11,27 +11,28 @@ its use of Coordinated Universal Time (UTC). \begin{code} {-# OPTIONS -#include "cbits/timezone.h" -#include "cbits/stgio.h" #-} module Time - ( - Month(..), - Day(..), + ( + Month(..) + , Day(..) - ClockTime(..), -- non-standard, lib. report gives this as abstract - getClockTime, + , ClockTime(..) -- non-standard, lib. report gives this as abstract + , getClockTime - TimeDiff(TimeDiff), - diffClockTimes, - addToClockTime, - timeDiffToString, -- non-standard - formatTimeDiff, -- non-standard + , TimeDiff(..) + , diffClockTimes + , addToClockTime - CalendarTime(CalendarTime), - toCalendarTime, - toUTCTime, - toClockTime, - calendarTimeToString, - formatCalendarTime + , timeDiffToString -- non-standard + , formatTimeDiff -- non-standard - ) where + , CalendarTime(..) + , toCalendarTime + , toUTCTime + , toClockTime + , calendarTimeToString + , formatCalendarTime + + ) where #ifdef __HUGS__ import PreludeBuiltin @@ -61,7 +62,7 @@ data Month deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) data Day - = Sunday | Monday | Tuesday | Wednesday + = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) @@ -94,7 +95,7 @@ we use the C library routines based on 32 bit integers. instance Show ClockTime #else instance Show ClockTime where - showsPrec p (TOD sec@(J# a# s# d#) nsec) = + showsPrec _ (TOD (J# _ s# d#) _nsec) = showString $ unsafePerformIO $ do buf <- allocChars 38 -- exactly enough for error message str <- _ccall_ showTime (I# s#) d# buf @@ -198,7 +199,7 @@ getClockTime = do i1 <- malloc1 i2 <- malloc1 rc <- _ccall_ getClockTime i1 i2 - if rc == 0 + if rc == (0 ::Int) then do sec <- cvtUnsigned i1 nsec <- cvtUnsigned i2 @@ -241,7 +242,7 @@ addToClockTime (TimeDiff year mon day hour min sec psec) (TOD c_sec c_psec) = unsafePerformIO $ do res <- allocWords sizeof_int64 rc <- prim_toClockSec year mon day hour min sec 0 res - if rc /= 0 + if rc /= (0::Int) then do diff_sec <- primReadInt64Array res 0 let diff_psec = psec @@ -253,9 +254,9 @@ addToClockTime :: TimeDiff -> ClockTime -> ClockTime addToClockTime (TimeDiff year mon day hour min sec psec) (TOD c_sec c_psec) = unsafePerformIO $ do res <- allocWords (``sizeof(time_t)'') - ptr <- _ccall_ toClockSec year mon day hour min sec 0 res + ptr <- _ccall_ toClockSec year mon day hour min sec (0::Int) res let (A# ptr#) = ptr - if ptr /= (``0''::Addr) + if ptr /= nullAddr then let diff_sec = (int2Integer (indexIntOffAddr# ptr# 0#)) diff_psec = psec @@ -343,7 +344,7 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is unsafePerformIO ( do res <- allocWords sizeof_int64 rc <- prim_toClockSec year mon mday hour min sec isDst res - if rc /= 0 + if rc /= (0::Int) then do tm <- primReadInt64Array res 0 return (TOD tm psec) @@ -353,12 +354,12 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is isDst = if isdst then (1::Int) else 0 #else toCalendarTime :: ClockTime -> IO CalendarTime -toCalendarTime (TOD sec@(J# a# s# d#) psec) = do +toCalendarTime (TOD (J# _ s# d#) psec) = do res <- allocWords (``sizeof(struct tm)''::Int) zoneNm <- allocChars 32 _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm tm <- _ccall_ toLocalTime (I# s#) d# res - if tm == (``NULL''::Addr) + if tm == nullAddr then constructErrorAndFail "Time.toCalendarTime: out of range" else do sec <- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm @@ -374,15 +375,15 @@ toCalendarTime (TOD sec@(J# a# s# d#) psec) = do tz <- _ccall_ GMTOFF tm let tzname = unpackCString zone return (CalendarTime (1900+year) mon mday hour min sec psec - (toEnum wday) yday tzname tz (isdst /= 0)) + (toEnum wday) yday tzname tz (isdst /= (0::Int))) toUTCTime :: ClockTime -> CalendarTime -toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformIO $ do +toUTCTime (TOD (J# _ s# d#) psec) = unsafePerformIO $ do res <- allocWords (``sizeof(struct tm)''::Int) zoneNm <- allocChars 32 _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm tm <- _ccall_ toUTCTime (I# s#) d# res - if tm == (``NULL''::Addr) + if tm == nullAddr then error "Time.toUTCTime: out of range" else do sec <- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm @@ -397,7 +398,7 @@ toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformIO $ do (toEnum wday) yday "UTC" 0 False) toClockTime :: CalendarTime -> ClockTime -toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz isdst) = +toClockTime (CalendarTime year mon mday hour min sec psec _wday _yday _tzname tz isdst) = if psec < 0 || psec > 999999999999 then error "Time.toClockTime: picoseconds out of range" else if tz < -43200 || tz > 43200 then @@ -407,7 +408,7 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is res <- allocWords (``sizeof(time_t)'') ptr <- _ccall_ toClockSec year mon mday hour min sec isDst res let (A# ptr#) = ptr - if ptr /= ``NULL'' + if ptr /= nullAddr then return (TOD (int2Integer (indexIntOffAddr# ptr# 0#)) psec) else error "Time.toClockTime: can't perform conversion" ) @@ -456,61 +457,62 @@ calendarTimeToString :: CalendarTime -> String calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String -formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec - wday yday tzname _ _) = +formatCalendarTime l fmt (CalendarTime year mon day hour min sec _ + wday yday tzname _ _) = doFmt fmt where doFmt ('%':c:cs) = decode c ++ doFmt cs doFmt (c:cs) = c : doFmt cs doFmt "" = "" - decode 'A' = fst (wDays l !! fromEnum wday) - decode 'a' = snd (wDays l !! fromEnum wday) - decode 'B' = fst (months l !! fromEnum mon) - decode 'b' = snd (months l !! fromEnum mon) - decode 'h' = snd (months l !! fromEnum mon) - decode 'C' = show2 (year `quot` 100) - decode 'c' = doFmt (dateTimeFmt l) + decode 'A' = fst (wDays l !! fromEnum wday) -- day of the week, full name + decode 'a' = snd (wDays l !! fromEnum wday) -- day of the week, abbrev. + decode 'B' = fst (months l !! fromEnum mon) -- month, full name + decode 'b' = snd (months l !! fromEnum mon) -- month, abbrev + decode 'h' = snd (months l !! fromEnum mon) -- ditto + decode 'C' = show2 (year `quot` 100) -- century + decode 'c' = doFmt (dateTimeFmt l) -- locale's data and time format. decode 'D' = doFmt "%m/%d/%y" - decode 'd' = show2 day - decode 'e' = show2' day - decode 'H' = show2 hour - decode 'I' = show2 (to12 hour) - decode 'j' = show3 yday - decode 'k' = show2' hour - decode 'l' = show2' (to12 hour) - decode 'M' = show2 min - decode 'm' = show2 (fromEnum mon+1) + decode 'd' = show2 day -- day of the month + decode 'e' = show2' day -- ditto, padded + decode 'H' = show2 hour -- hours, 24-hour clock, padded + decode 'I' = show2 (to12 hour) -- hours, 12-hour clock + decode 'j' = show3 yday -- day of the year + decode 'k' = show2' hour -- hours, 24-hour clock, no padding + decode 'l' = show2' (to12 hour) -- hours, 12-hour clock, no padding + decode 'M' = show2 min -- minutes + decode 'm' = show2 (fromEnum mon+1) -- numeric month decode 'n' = "\n" - decode 'p' = (if hour < 12 then fst else snd) (amPm l) + decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm decode 'R' = doFmt "%H:%M" decode 'r' = doFmt (time12Fmt l) decode 'T' = doFmt "%H:%M:%S" decode 't' = "\t" - decode 'S' = show2 sec - decode 's' = show2 sec -- Implementation-dependent, sez the lib doc.. - decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) - decode 'u' = show (let n = fromEnum wday in + decode 'S' = show2 sec -- seconds + decode 's' = show2 sec -- number of secs since Epoch. (ToDo.) + decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday. + decode 'u' = show (let n = fromEnum wday in -- numeric day of the week (1=Monday, 7=Sunday) if n == 0 then 7 else n) - decode 'V' = - let (week, days) = + decode 'V' = -- week number (as per ISO-8601.) + let (week, days) = -- [yep, I've always wanted to be able to display that too.] (yday + 7 - if fromEnum wday > 0 then fromEnum wday - 1 else 6) `divMod` 7 in show2 (if days >= 4 then week+1 else if week == 0 then 53 else week) - decode 'W' = + decode 'W' = -- week number, weeks starting on monday show2 ((yday + 7 - if fromEnum wday > 0 then fromEnum wday - 1 else 6) `div` 7) - decode 'w' = show (fromEnum wday) - decode 'X' = doFmt (timeFmt l) - decode 'x' = doFmt (dateFmt l) - decode 'Y' = show year - decode 'y' = show2 (year `rem` 100) - decode 'Z' = tzname + decode 'w' = show (fromEnum wday) -- numeric day of the week, weeks starting on Sunday. + decode 'X' = doFmt (timeFmt l) -- locale's preferred way of printing time. + decode 'x' = doFmt (dateFmt l) -- locale's preferred way of printing dates. + decode 'Y' = show year -- year, including century. + decode 'y' = show2 (year `rem` 100) -- year, within century. + decode 'Z' = tzname -- timezone name decode '%' = "%" decode c = [c] + show2, show2', show3 :: Int -> String show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] @@ -518,15 +520,18 @@ show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) -to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h +to12 :: Int -> Int +to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h' \end{code} +Useful extensions for formatting TimeDiffs. + \begin{code} timeDiffToString :: TimeDiff -> String timeDiffToString = formatTimeDiff defaultTimeLocale "%c" formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String -formatTimeDiff l fmt ct@(TimeDiff year month day hour min sec psec) +formatTimeDiff l fmt (TimeDiff year month day hour min sec _) = doFmt fmt where doFmt "" = ""