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..)
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Array]{Module @Array@}
\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
{-# 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]
\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'
import PrelIOBase
import PrelST
#endif
-import IO ( fail )
+import IO ( ioError )
import Ratio
#ifdef __HUGS__
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
fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 +
fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000)
else
- fail (IOError Nothing UnsupportedOperation "getCPUTime"
- "can't get CPU time")
+ ioError (IOError Nothing UnsupportedOperation
+ "getCPUTime"
+ "can't get CPU time")
#endif
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Char]{Module @Char@}
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}
| isDigit c = fromEnum c - fromEnum '0'
| c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
| c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
- | otherwise = error "Char.digitToInt: not a digit" -- sigh
+ | otherwise = error ("Char.digitToInt: not a digit " ++ show c) -- sigh
\end{code}
%
-% (c) The AQUA Project, Glasgow University, 1994-1997
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Complex]{Module @Complex@}
\begin{code}
-module Complex (
- Complex((:+)),
-
- realPart, imagPart, conjugate, mkPolar,
- cis, polar, magnitude, phase
- ) where
+module Complex
+ ( Complex((:+))
+
+ , realPart -- :: (RealFloat a) => Complex a -> a
+ , imagPart -- :: (RealFloat a) => Complex a -> a
+ , conjugate -- :: (RealFloat a) => Complex a -> Complex a
+ , mkPolar -- :: (RealFloat a) => a -> a -> Complex a
+ , cis -- :: (RealFloat a) => a -> Complex a
+ , polar -- :: (RealFloat a) => Complex a -> (a,a)
+ , magnitude -- :: (RealFloat a) => Complex a -> a
+ , phase -- :: (RealFloat a) => Complex a -> a
+
+ -- Complex instances:
+ --
+ -- (RealFloat a) => Eq (Complex a)
+ -- (RealFloat a) => Read (Complex a)
+ -- (RealFloat a) => Show (Complex a)
+ -- (RealFloat a) => Num (Complex a)
+ -- (RealFloat a) => Fractional (Complex a)
+ -- (RealFloat a) => Floating (Complex a)
+ --
+ -- Implementation checked wrt. Haskell 98 lib report, 1/99.
+
+ ) where
import Prelude
%*********************************************************
\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}
\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)
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}
asin z@(x:+y) = y':+(-x')
where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
- acos z@(x:+y) = y'':+(-x'')
+ acos z = y'':+(-x'')
where (x'':+y'') = log (z + ((-y'):+x'))
(x':+y') = sqrt (1 - z*z)
atan z@(x:+y) = y':+(-x')
%
-% (c) The AQUA Project, Glasgow University, 1994-1997
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Directory]{Directory interface}
{-# OPTIONS -#include <sys/stat.h> -#include <dirent.h> -#include "cbits/stgio.h" #-}
module Directory
(
- Permissions(Permissions),
-
- createDirectory,
- removeDirectory,
- renameDirectory,
- getDirectoryContents,
- getCurrentDirectory,
- setCurrentDirectory,
-
- removeFile,
- renameFile,
-
- doesFileExist,
- doesDirectoryExist,
- getPermissions,
- setPermissions,
+ Permissions(Permissions,readable,writable,executable,searchable)
+
+ , createDirectory -- :: FilePath -> IO ()
+ , removeDirectory -- :: FilePath -> IO ()
+ , renameDirectory -- :: FilePath -> FilePath -> IO ()
+
+ , getDirectoryContents -- :: FilePath -> IO [FilePath]
+ , getCurrentDirectory -- :: IO FilePath
+ , setCurrentDirectory -- :: FilePath -> IO ()
+
+ , removeFile -- :: FilePath -> IO ()
+ , renameFile -- :: FilePath -> FilePath -> IO ()
+
+ , doesFileExist -- :: FilePath -> IO Bool
+ , doesDirectoryExist -- :: FilePath -> IO Bool
+
+ , getPermissions -- :: FilePath -> IO Permissions
+ , setPermissions -- :: FilePath -> Permissions -> IO ()
+
+
#ifndef __HUGS__
- getModificationTime
+ , getModificationTime -- :: FilePath -> IO ClockTime
#endif
) where
import PrelHandle
import PrelST
import PrelArr
-import PrelPack ( unpackNBytesST )
+import PrelPack ( unpackNBytesST, packString, unpackCStringST )
import PrelAddr
import Time ( ClockTime(..) )
#endif
%*********************************************************
%* *
-\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}
%* *
%*********************************************************
\begin{code}
data Permissions
= Permissions {
- readable, writeable,
+ readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
\end{code}
\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}
\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
\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
\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
\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
\end{itemize}
\begin{code}
---getDirectoryContents :: FilePath -> IO [FilePath]
-#ifdef __HUGS__
+getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
dir <- primOpenDir (primPackString path)
if dir == nullAddr
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,
\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"
\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
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
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
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}
+
-- 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 ()
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,
import PrelAddr ( Addr(..), nullAddr )
import PrelArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
-import PrelException ( fail, catch )
+import PrelException ( ioError, catch )
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( ForeignObj )
-- 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
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"
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"
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 ""
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 ""
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
-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 ""
#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 =
#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 =
#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
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
after x
case rs of
Right r -> return r
- Left e -> fail e
+ Left e -> ioError e
\end{code}
%*********************************************************
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Ix]{Module @Ix@}
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 )
%*********************************************************
\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
\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
----------------------------------------------------------------------
%
-% (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 \\
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
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]
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
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,
-- 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:
-> 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
-> 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
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
-- 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
_ -> 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 =
#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}
%
-% (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}
__interface Main 1 where
__export Main main ;
-1 main :: PrelIOBase.IO PrelBase.();
+1 main :: __forall [a] => PrelIOBase.IO a;
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Maybe]{Module @Maybe@}
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
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
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}
%
-% (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}
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 ()
%
-% (c) The AQUA Project, Glasgow University, 1997-98
+% (c) The AQUA Project, Glasgow University, 1997-99
%
\section[Numeric]{Numeric interface}
\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
\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) ->
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))
#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 ()
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
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
\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),
%*********************************************************
\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)
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# #) ->
-> 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
-> 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#
}}
-> 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
-> 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# ->
-> 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
-> 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# ->
-> 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
-> 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# ->
-> 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
-> 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)
-> 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"
-> 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#
}}
-> 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
-> 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# ->
-> 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
-> 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}
\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@
(==), (/=) :: a -> a -> Bool
x /= y = not (x == y)
+ x == y = not (x /= y)
class (Eq a) => Ord a where
compare :: a -> a -> Ordering
%*********************************************************
%* *
-\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}
\begin{code}
class Enum a where
+ succ, pred :: a -> a
toEnum :: Int -> a
fromEnum :: a -> Int
enumFrom :: a -> [a] -- [n..]
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]
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
\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')
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}
%*********************************************************
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
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}
\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
-- (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
#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 "<<void>>"
- showList ls = showList__ (showsPrec 0) ls
-\end{code}
-
-
-%*********************************************************
-%* *
\subsection{Type @Bool@}
%* *
%*********************************************************
(&&), (||) :: Bool -> Bool -> Bool
True && x = x
-False && x = False
-True || x = True
+False && _ = False
+True || _ = True
False || x = x
not :: Bool -> Bool
compare () () = EQ
instance Enum () where
+ succ x = x
+ pred x = x
toEnum 0 = ()
toEnum _ = error "Prelude.Enum.().toEnum: argument not 0"
fromEnum () = 0
enumFromThenTo () () () = [()]
instance Show () where
- showsPrec p () = showString "()"
+ showsPrec _ () = showString "()"
showList ls = showList__ (showsPrec 0) ls
\end{code}
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))
| 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)
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",
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
#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)
(J# a1 s1 d1) /= (J# a2 s2 d2)
= (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
+
\end{code}
%*********************************************************
\begin{code}
instance Show (a -> b) where
- showsPrec p f = showString "<<function>>"
+ showsPrec _ _ = showString "<<function>>"
showList ls = showList__ (showsPrec 0) ls
asTypeOf = const
\end{code}
-
-%*********************************************************
-%* *
-\subsection{Miscellaneous}
-%* *
-%*********************************************************
-
-
-\begin{code}
-data Lift a = Lift a
-\end{code}
-
-
-
-
%*********************************************************
%* *
\subsection{Support code for @Show@}
shows :: (Show a) => a -> ShowS
shows = showsPrec 0
-show :: (Show a) => a -> String
-show x = shows x ""
-
showChar :: Char -> ShowS
showChar = (:)
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
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
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}
\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}
%*********************************************************
{-# 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
\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#
-- 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}
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)
--
#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
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}
@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# ->
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}
, error -- :: String -> a
, assertError -- :: String -> Bool -> a -> a
+
) where
import PrelBase
-- 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}
%*********************************************************
location message details
\begin{code}
+untangle :: String -> String -> String
untangle coded message
= location
++ ": "
++ "\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}
---------------------------------------------------------------------------
__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 ;
% -----------------------------------------------------------------------------
-% $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
%
\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
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:
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
course.
\begin{code}
-fail :: IOError -> IO a
-fail err = throw (IOException err)
+ioError :: IOError -> IO a
+ioError err = throw (IOException err)
\end{code}
CCallable
CReturnable
- Void
--- void CAF is defined in PrelBase
-
-- Magical assert thingy
assert
newMVar#
takeMVar#
putMVar#
+ isEmptyMVar#
-- Parallel
seq#
+#
-#
*#
- /#
quotInt#
remInt#
negateInt#
not#
xor#
shiftL#
- shiftRA#
shiftRL#
int2Word#
word2Int#
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.
import Ix
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj, writeForeignObj )
+import PrelForeign ( makeForeignObj )
#endif
#endif /* ndef(__HUGS__) */
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
)
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__
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__
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
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'
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
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__ })
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
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_
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
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"
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
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
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
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
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
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
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
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
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"
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"
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"
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"
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 ()
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)
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.
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.
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
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
ioeGetFileName (IOError _ _ _ str) =
case span (/=':') str of
- (fs,[]) -> Nothing
+ (_,[]) -> Nothing
(fs,_) -> Just fs
\end{code}
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
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
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
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
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
ioe_closedHandle fun handle
AppendHandle -> do
writeHandle handle handle_
- fail not_seekable_error
+ ioError not_seekable_error
_ -> act handle_
where
not_seekable_error =
\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
#endif
-#ifdef __HUGS__
+-- #ifdef __HUGS__
+#if 1
threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
-- Hugs does actually have the primops needed to implement these
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}
% -----------------------------------------------------------------------------
-% $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
%
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
#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 #-}
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
deriving (Eq)
instance Show IOErrorType where
- showsPrec d e =
+ showsPrec _ e =
showString $
case e of
AlreadyExists -> "already exists"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UserError _ -> "failed"
+ UnsupportedOperation -> "unsupported operation"
EOF -> "end of file"
\end{code}
\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}
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}
CCALL(getErrStr__) >>= \ str ->
let
iot =
- case errtype of
+ case (errtype::Int) of
ERR_ALREADYEXISTS -> AlreadyExists
ERR_HARDWAREFAULT -> HardwareFault
ERR_ILLEGALOPERATION -> IllegalOperation
_ -> 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
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
-- 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]
-- 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
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:
-- 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
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)
-- 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"
-- 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
| 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
(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
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)
#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)
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)
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
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
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}
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}
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}
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
fromRational :: Rational -> a
recip x = 1 / x
+ x / y = x * recip y
class (Fractional a) => Floating a where
pi :: a
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
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}
%*********************************************************
-- 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
= 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
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
-- 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)
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}
%*********************************************************
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}
\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}
%*********************************************************
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,
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 (^^) ::
(^^) :: (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}
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}
(0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- ..
isNegativeZero x =
(0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ...
- isIEEE x = True
+ isIEEE _ = True
\end{code}
%*********************************************************
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#)
(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
fromIntegral :: (Integral a, Num b) => a -> b
fromIntegral = fromInteger . toInteger
-{- SPECIALIZE fromRealFrac ::
+{- SPECIALIZE realToFrac ::
Double -> Rational,
Rational -> Double,
Float -> Rational,
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}
%*********************************************************
\begin{code}
instance Enum Float where
+ succ x = x + 1
+ pred x = x - 1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
enumFromThenTo = numericEnumFromThenTo
instance Enum Double where
+ succ x = x + 1
+ pred x = x - 1
toEnum = fromIntegral
fromEnum = fromInteger . truncate -- may overflow
enumFrom = numericEnumFrom
\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'
(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
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
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)
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
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
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)
-- 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]]
-- 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}
%*********************************************************
--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.
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
_ ->
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}
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
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"
-- 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
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
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
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)
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
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)
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}
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
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
| 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
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)
-- needed for readIO.
import PrelIOBase ( IO, userError )
-import PrelException ( fail )
+import PrelException ( ioError )
\end{code}
%*********************************************************
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
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}
(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
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}
%*********************************************************
\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
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) }) ++
instance Read Ordering where
- readsPrec p = readParen False
+ readsPrec _ = readParen False
(\r ->
lex r >>= \ lr ->
(do { ("LT", rest) <- return lr ; return (LT, rest) }) ++
(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)}) ++
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
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)
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
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
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
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
\begin{code}
readLitChar :: ReadS Char
+readLitChar [] = mzero
readLitChar ('\\':s) = readEsc s
where
readEsc ('a':s) = return ('\a',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)
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)
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 #) }
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
)
instance Show (ST s a) where
- showsPrec p f = showString "<<ST action>>"
+ showsPrec _ _ = showString "<<ST action>>"
showList = showList__ (showsPrec 0)
\end{code}
\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 ')'
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 ',' .
\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.
-> 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
-- 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
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
+%
+% (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
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''
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}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Ratio]{Module @Ratio@}
\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}
-
-
%
-% (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__
#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}
\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
\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
\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
-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}
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}
%
-% (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}
\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
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)
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
i1 <- malloc1
i2 <- malloc1
rc <- _ccall_ getClockTime i1 i2
- if rc == 0
+ if rc == (0 ::Int)
then do
sec <- cvtUnsigned i1
nsec <- cvtUnsigned i2
(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
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
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)
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
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
(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
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"
)
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)]
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 "" = ""
projects / ghc-hetmet.git / commitdiff