From: sof Date: Fri, 14 Mar 1997 05:22:34 +0000 (+0000) Subject: [project @ 1997-03-14 05:22:26 by sof] X-Git-Tag: Approximately_1000_patches_recorded~788 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1401a0281a8d6a3f41e744047db68e04cf812651;p=ghc-hetmet.git [project @ 1997-03-14 05:22:26 by sof] OGI changes through 130397 --- diff --git a/ghc/lib/required/Array.lhs b/ghc/lib/required/Array.lhs index 96cc4a5..b3d0f4d 100644 --- a/ghc/lib/required/Array.lhs +++ b/ghc/lib/required/Array.lhs @@ -9,10 +9,10 @@ module Array ( module Ix, -- export all of Ix - Array, -- Array type abstractly + Array, -- Array type is abstract array, listArray, (!), bounds, indices, elems, assocs, - accumArray, (//), accum, amap, ixmap + accumArray, (//), accum, ixmap ) where import Ix @@ -73,6 +73,9 @@ ixmap b f a = array b [(i, a ! f i) | i <- range b] %********************************************************* \begin{code} +instance Ix a => Functor (Array a) where + map = amap + instance (Ix a, Eq b) => Eq (Array a b) where a == a' = assocs a == assocs a' a /= a' = assocs a /= assocs a' diff --git a/ghc/lib/required/Char.lhs b/ghc/lib/required/Char.lhs index c58750a..b95487a 100644 --- a/ghc/lib/required/Char.lhs +++ b/ghc/lib/required/Char.lhs @@ -7,15 +7,44 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module Char ( - isAscii, isControl, isPrint, isSpace, isUpper, isLower, - isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum, toUpper, toLower - ) where +module Char + ( + isAscii, isLatin1, isControl, + isPrint, isSpace, isUpper, + isLower, isAlpha, isDigit, + isOctDigit, isHexDigit, isAlphanum, -- :: Char -> Bool + + toUpper, toLower, -- :: Char -> Char + + digitToInt, -- :: Char -> Int + intToDigit, -- :: Int -> Char + + ord, -- :: Char -> Int + chr, -- :: Int -> Char + readLitChar, -- :: ReadS Char + showLitChar -- :: Char -> ShowS + ) where import PrelBase -\end{code} +import PrelRead (readLitChar) +import IOBase (error) +\end{code} +\begin{code} +-- Digit conversion operations +digitToInt :: Char -> Int +digitToInt c + | isDigit c = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 + | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 + | otherwise = error "Char.digitToInt: not a digit" -- sigh +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" -- .... +\end{code} diff --git a/ghc/lib/required/Complex.lhs b/ghc/lib/required/Complex.lhs index 69e753e..cfbeb83 100644 --- a/ghc/lib/required/Complex.lhs +++ b/ghc/lib/required/Complex.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1997 % \section[Complex]{Module @Complex@} diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs index 20d05dd..e9f70e9 100644 --- a/ghc/lib/required/Directory.lhs +++ b/ghc/lib/required/Directory.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The AQUA Project, Glasgow University, 1994-1997 % \section[Directory]{Module @Directory@} @@ -19,9 +19,15 @@ are relative to the current directory. \begin{code} module Directory ( +-- Permissions(Permissions), createDirectory, removeDirectory, removeFile, renameDirectory, renameFile, getDirectoryContents, getCurrentDirectory, setCurrentDirectory +{- + ,doesFileExist, doesDirectoryExist, + getPermissions, setPermissions, + getModificationTime +-} ) where import Prelude @@ -51,39 +57,57 @@ setCurrentDirectory :: FilePath -> IO () %********************************************************* %* * -\subsection{Signatures} +\subsection{Permissions} %* * %********************************************************* -$createDirectory dir$ creates a new directory -{\em dir} which is initially empty, or as near to empty as the -operating system allows. +The @Permissions@ type is used to record whether certain operations are permissible on a +file/directory: + +\begin{code} +data Permissions + = Permissions { + readable, writeable, + executable, searchable :: Bool + } deriving (Eq, Ord, Read, Show) + +\end{code} + +%********************************************************* +%* * +\subsection{Implementation} +%* * +%********************************************************* + +@createDirectory dir@ creates a new directory {\em dir} which is +initially empty, or as near to empty as the operating system +allows. The operation may fail with: + \begin{itemize} -\item $AlreadyExists$ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES]@ +\item @isAlreadyExistsError@ / @AlreadyExists@ The operand refers to a directory that already exists. -[$EEXIST$] -\item $HardwareFault$ +@ [EEXIST]@ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@ [EIO]@ +\item @InvalidArgument@ The operand is not a valid directory name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @NoSuchThing@ There is no path to the directory. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ -The process has insufficient privileges to perform the operation. -[$EROFS$, $EACCES$] -\item $ResourceExhausted$ +@[ENOENT, ENOTDIR]@ +\item @ResourceExhausted@ Insufficient resources (virtual memory, process file descriptors, physical disk space, etc.) are available to perform the operation. -[$EDQUOT$, $ENOSPC$, $ENOMEM$, -$EMLINK$] -\item $InappropriateType$ +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @InappropriateType@ The path refers to an existing non-directory object. -[$EEXIST$] +@[EEXIST]@ \end{itemize} \begin{code} @@ -95,7 +119,7 @@ createDirectory path = constructErrorAndFail "createDirectory" \end{code} -$removeDirectory dir$ removes an existing directory {\em dir}. The +@removeDirectory dir@ removes an existing directory {\em dir}. The implementation may specify additional constraints which must be satisfied before a directory can be removed (e.g. the directory has to be empty, or may not be in use by other processes). It is not legal @@ -106,27 +130,27 @@ directory). The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +[@EIO@] +\item @InvalidArgument@ The operand is not a valid directory name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExist@ / @NoSuchThing@ The directory does not exist. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EROFS$, $EACCES$, $EPERM$] -\item $UnsatisfiedConstraints$ +@[EROFS, EACCES, EPERM]@ +\item @UnsatisfiedConstraints@ Implementation-dependent constraints are not satisfied. -[$EBUSY$, $ENOTEMPTY$, $EEXIST$] -\item $UnsupportedOperation$ +@[EBUSY, ENOTEMPTY, EEXIST]@ +\item @UnsupportedOperation@ The implementation does not support removal in this situation. -[$EINVAL$] -\item $InappropriateType$ +@[EINVAL]@ +\item @InappropriateType@ The operand refers to an existing non-directory object. -[$ENOTDIR$] +@[ENOTDIR]@ \end{itemize} \begin{code} @@ -138,7 +162,7 @@ removeDirectory path = constructErrorAndFail "removeDirectory" \end{code} -$removeFile file$ removes the directory entry for an existing file +@removeFile file@ removes the directory entry for an existing file {\em file}, where {\em file} is not itself a directory. The implementation may specify additional constraints which must be satisfied before a file can be removed (e.g. the file may not be in @@ -146,24 +170,24 @@ use by other processes). The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@[EIO]@ +\item @InvalidArgument@ The operand is not a valid file name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExist@ / @NoSuchThing@ The file does not exist. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EROFS$, $EACCES$, $EPERM$] -\item $UnsatisfiedConstraints$ +@[EROFS, EACCES, EPERM]@ +\item @UnsatisfiedConstraints@ Implementation-dependent constraints are not satisfied. -[$EBUSY$] -\item $InappropriateType$ +@[EBUSY]@ +\item @InappropriateType@ The operand refers to an existing directory. -[$EPERM$, $EINVAL$] +@[EPERM, EINVAL]@ \end{itemize} \begin{code} @@ -175,7 +199,7 @@ removeFile path = constructErrorAndFail "removeFile" \end{code} -$renameDirectory old$ {\em new} changes the name of an existing +@renameDirectory old@ {\em new} changes the name of an existing directory from {\em old} to {\em new}. If the {\em new} directory already exists, it is atomically replaced by the {\em old} directory. If the {\em new} directory is neither the {\em old} directory nor an @@ -187,31 +211,30 @@ must be documented. The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@[EIO]@ +\item @InvalidArgument@ Either operand is not a valid directory name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ The original directory does not exist, or there is no path to the target. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EROFS$, $EACCES$, $EPERM$] -\item $ResourceExhausted$ +@[EROFS, EACCES, EPERM]@ +\item @ResourceExhausted@ Insufficient resources are available to perform the operation. -[$EDQUOT$, $ENOSPC$, $ENOMEM$, -$EMLINK$] -\item $UnsatisfiedConstraints$ +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @UnsatisfiedConstraints@ Implementation-dependent constraints are not satisfied. -[$EBUSY$, $ENOTEMPTY$, $EEXIST$] -\item $UnsupportedOperation$ +@[EBUSY, ENOTEMPTY, EEXIST]@ +\item @UnsupportedOperation@ The implementation does not support renaming in this situation. -[$EINVAL$, $EXDEV$] -\item $InappropriateType$ +@[EINVAL, EXDEV]@ +\item @InappropriateType@ Either path refers to an existing non-directory object. -[$ENOTDIR$, $EISDIR$] +@[ENOTDIR, EISDIR]@ \end{itemize} \begin{code} @@ -223,7 +246,7 @@ renameDirectory opath npath = constructErrorAndFail "renameDirectory" \end{code} -$renameFile old$ {\em new} changes the name of an existing file system +@renameFile old@ {\em new} changes the name of an existing file system object from {\em old} to {\em new}. If the {\em new} object already exists, it is atomically replaced by the {\em old} object. Neither path may refer to an existing directory. A conformant implementation @@ -233,32 +256,30 @@ documented. The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@[EIO]@ +\item @InvalidArgument@ Either operand is not a valid file name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ The original file does not exist, or there is no path to the target. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EROFS$, $EACCES$, $EPERM$] -\item $ResourceExhausted$ +@[EROFS, EACCES, EPERM]@ +\item @ResourceExhausted@ Insufficient resources are available to perform the operation. -[$EDQUOT$, $ENOSPC$, $ENOMEM$, -$EMLINK$] -\item $UnsatisfiedConstraints$ +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @UnsatisfiedConstraints@ Implementation-dependent constraints are not satisfied. -[$EBUSY$] -\item $UnsupportedOperation$ +@[EBUSY]@ +\item @UnsupportedOperation@ The implementation does not support renaming in this situation. -[$EXDEV$] -\item $InappropriateType$ +@[EXDEV]@ +\item @InappropriateType@ Either path refers to an existing directory. -[$ENOTDIR$, $EISDIR$, $EINVAL$, -$EEXIST$, $ENOTEMPTY$] +@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ \end{itemize} \begin{code} @@ -270,29 +291,29 @@ renameFile opath npath = constructErrorAndFail "renameFile" \end{code} -$getDirectoryContents dir$ returns a list of -all entries in {\em dir}. +@getDirectoryContents dir@ returns a list of {\em all} entries +in {\em dir}. The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@[EIO]@ +\item @InvalidArgument@ The operand is not a valid directory name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ The directory does not exist. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EACCES$] -\item $ResourceExhausted$ +@[EACCES]@ +\item @ResourceExhausted@ Insufficient resources are available to perform the operation. -[$EMFILE$, $ENFILE$] -\item $InappropriateType$ +@[EMFILE, ENFILE]@ +\item @InappropriateType@ The path refers to an existing non-directory object. -[$ENOTDIR$] +@[ENOTDIR]@ \end{itemize} \begin{code} @@ -319,23 +340,23 @@ getDirectoryContents path = \end{code} If the operating system has a notion of current directories, -$getCurrentDirectory$ returns an absolute path to the +@getCurrentDirectory@ returns an absolute path to the current directory of the calling process. The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $NoSuchThing$ +@[EIO]@ +\item @isDoesNotExistError@ / @NoSuchThing@ There is no path referring to the current directory. -[$EPERM$, $ENOENT$, $ESTALE$...] -\item $PermissionDenied$ +@[EPERM, ENOENT, ESTALE...]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EACCES$] -\item $ResourceExhausted$ +@[EACCES]@ +\item @ResourceExhausted@ Insufficient resources are available to perform the operation. -\item $UnsupportedOperation$ +\item @UnsupportedOperation@ The operating system has no notion of current directory. \end{itemize} @@ -352,29 +373,29 @@ getCurrentDirectory = \end{code} If the operating system has a notion of current directories, -$setCurrentDirectory dir$ changes the current +@setCurrentDirectory dir@ changes the current directory of the calling process to {\em dir}. The operation may fail with: \begin{itemize} -\item $HardwareFault$ +\item @HardwareFault@ A physical I/O error has occurred. -[$EIO$] -\item $InvalidArgument$ +@[EIO]@ +\item @InvalidArgument@ The operand is not a valid directory name. -[$ENAMETOOLONG$, $ELOOP$] -\item $NoSuchThing$ +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ The directory does not exist. -[$ENOENT$, $ENOTDIR$] -\item $PermissionDenied$ +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ The process has insufficient privileges to perform the operation. -[$EACCES$] -\item $UnsupportedOperation$ +@[EACCES]@ +\item @UnsupportedOperation@ The operating system has no notion of current directory, or the current directory cannot be dynamically changed. -\item $InappropriateType$ +\item @InappropriateType@ The path refers to an existing non-directory object. -[$ENOTDIR$] +@[ENOTDIR]@ \end{itemize} \begin{code} @@ -387,3 +408,38 @@ setCurrentDirectory path = \end{code} + +\begin{code} +{- +doesFileExist :: FilePath -> IO Bool +doesFileExist name = + psToByteArrayST name `thenIO_Prim` \ path -> + _ccall_ access path (``F_OK''::Int) `thenIO_Prim` \ rc -> + return (rc == 0) + +doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + (getFileStatus >>= isDirectory) `catch` (\ _ -> return False) + +getModificationTime :: FilePath -> IO Bool +getModificationTime name = + getFileStatus >>= \ st -> + return (modificationTime st) + +getPermissions :: FilePath -> IO Permissions +getPermissions name = + getFileStatus >>= \ st -> + let + fm = fileMode st + isect v = intersectFileMode v fm == v + in + return ( + Permissions { + readable = isect ownerReadMode, + writeable = isect ownerWriteMode, + executable = not (isDirectory st) && isect ownerExecuteMode, + searchable = not (isRegularFile st) && isect ownerExecuteMode + } + ) +-} +\end{code} diff --git a/ghc/lib/required/IO.lhs b/ghc/lib/required/IO.lhs index b629c6a..34d5a33 100644 --- a/ghc/lib/required/IO.lhs +++ b/ghc/lib/required/IO.lhs @@ -5,7 +5,7 @@ \section[IO]{Module @IO@} \begin{code} -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} module IO ( Handle, HandlePosn, @@ -15,13 +15,19 @@ module IO ( SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), stdin, stdout, stderr, - openFile, hClose, hFileSize, hIsEOF, isEOF, - hSetBuffering, hGetBuffering, hFlush, hGetPosn, hSetPosn, hSeek, - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hReady, - hGetChar, hLookAhead, hGetContents, hPutChar, hPutStr, hPrint, - isAlreadyExistsError, isAlreadyInUseError, isFullError, isEOFError, + openFile, hClose, + hFileSize, hIsEOF, isEOF, + hSetBuffering, hGetBuffering, hFlush, + hGetPosn, hSetPosn, hSeek, + hReady, hGetChar, hLookAhead, hGetContents, + hPutChar, hPutStr, hPutStrLn, hPrint, + hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, + + isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, + isFullError, isEOFError, isIllegalOperation, isPermissionError, isUserError, + ioeGetErrorString, ioeGetHandle, ioeGetFileName ) where @@ -33,6 +39,7 @@ import IOHandle -- much of the real stuff is in here import PackedString ( nilPS, packCBytesST, unpackPS ) import PrelBase import GHC +import Foreign ( makeForeignObj ) \end{code} %********************************************************* @@ -59,11 +66,13 @@ hLookAhead :: Handle -> IO Char hPrint :: Show a => Handle -> a -> IO () hPutChar :: Handle -> Char -> IO () hPutStr :: Handle -> String -> IO () +hPutStrLn :: Handle -> String -> IO () hReady :: Handle -> IO Bool --IOHandle:hSeek :: Handle -> SeekMode -> Integer -> IO () --IOHandle:hSetBuffering :: Handle -> BufferMode -> IO () --IOHandle:hSetPosn :: HandlePosn -> IO () -- ioeGetFileName :: IOError -> Maybe FilePath +-- ioeGetErrorString :: IOError -> Maybe String -- ioeGetHandle :: IOError -> Maybe Handle -- isAlreadyExistsError :: IOError -> Bool -- isAlreadyInUseError :: IOError -> Bool @@ -96,16 +105,16 @@ hReady handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") WriteHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") other -> _ccall_ inputReady (filePtr other) `thenIO_Prim` \ rc -> writeHandle handle (markHandle htype) >> @@ -129,16 +138,16 @@ hGetChar handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") WriteHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") other -> _ccall_ fileGetc (filePtr other) `thenIO_Prim` \ intc -> writeHandle handle (markHandle htype) >> @@ -163,16 +172,16 @@ hLookAhead handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") WriteHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") other -> _ccall_ fileLookAhead (filePtr other) `thenIO_Prim` \ intc -> writeHandle handle (markHandle htype) >> @@ -204,16 +213,16 @@ hGetContents handle = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle AppendHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") WriteHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for reading") + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") other -> {- To avoid introducing an extra layer of buffering here, @@ -250,7 +259,7 @@ hGetContents handle = if buf /= ``NULL'' then return (buf, size) else - fail (ResourceExhausted "not enough virtual memory") + fail (IOError Nothing ResourceExhausted "not enough virtual memory") where size = case msize of @@ -280,7 +289,8 @@ lazyReadBlock handle = then return nilPS else packCBytesST bytes buf) >>= \ some -> if bytes < 0 then - ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) + makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> + ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0))) >> _ccall_ free buf >>= \ () -> _ccall_ closeFile fp >> @@ -304,7 +314,8 @@ lazyReadLine handle = then return nilPS else packCBytesST bytes buf) >>= \ some -> if bytes < 0 then - ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) + makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> + ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0))) >> _ccall_ free buf >>= \ () -> _ccall_ closeFile fp >> @@ -325,7 +336,8 @@ lazyReadChar handle = SemiClosedHandle fp buf_info -> _ccall_ readChar fp >>= \ char -> if char == ``EOF'' then - ioToST (writeHandle handle (SemiClosedHandle ``NULL'' buf_info)) + makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> + ioToST (writeHandle handle (SemiClosedHandle null_fp buf_info)) >> _ccall_ closeFile fp >> returnPrimIO "" @@ -358,13 +370,13 @@ hPutChar handle c = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle ReadHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for writing") + fail (IOError (Just handle) IllegalOperation "handle is not open for writing") other -> _ccall_ filePutc (filePtr other) (ord c) `thenIO_Prim` \ rc -> writeHandle handle (markHandle htype) >> @@ -388,13 +400,13 @@ hPutStr handle str = fail ioError ClosedHandle -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle SemiClosedHandle _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is closed") + ioe_closedHandle handle ReadHandle _ _ _ -> writeHandle handle htype >> - fail (IllegalOperation "handle is not open for writing") + fail (IOError (Just handle) IllegalOperation "handle is not open for writing") other -> getBufferMode other `thenIO_Prim` \ other -> (case bufferMode other of @@ -413,10 +425,10 @@ hPutStr handle str = else constructErrorAndFail "hPutStr" where - writeLines :: Addr -> String -> PrimIO Bool + writeLines :: ForeignObj -> String -> PrimIO Bool writeLines = writeChunks ``BUFSIZ'' True - writeBlocks :: Addr -> Int -> String -> PrimIO Bool + writeBlocks :: ForeignObj -> Int -> String -> PrimIO Bool writeBlocks fp size s = writeChunks size False fp s {- @@ -431,7 +443,7 @@ hPutStr handle str = a whole lot quicker. -- SOF 3/96 -} - writeChunks :: Int -> Bool -> Addr -> String -> PrimIO Bool + writeChunks :: Int -> Bool -> ForeignObj -> String -> PrimIO Bool writeChunks (I# bufLen) chopOnNewLine fp s = newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) -> @@ -466,7 +478,7 @@ hPutStr handle str = in shoveString 0# s - writeChars :: Addr -> String -> PrimIO Bool + writeChars :: ForeignObj -> String -> PrimIO Bool writeChars fp "" = returnPrimIO True writeChars fp (c:cs) = _ccall_ filePutc fp (ord c) >>= \ rc -> @@ -480,7 +492,20 @@ Computation $hPrint hdl t$ writes the string representation of {\em t} given by the $shows$ function to the file or channel managed by {\em hdl}. +SOF 2/97: Seem to have disappeared in 1.4 libs. + \begin{code} --hPrint :: Show a => Handle -> a -> IO () hPrint hdl = hPutStr hdl . show \end{code} + +Derived action @hPutStrLn hdl str@ writes the string \tr{str} to +the handle \tr{hdl}, adding a newline at the end. + +\begin{code} +--hPutStrLn :: Handle -> String -> IO () +hPutStrLn hndl str = do + hPutStr hndl str + hPutChar hndl '\n' + +\end{code} diff --git a/ghc/lib/required/Ix.lhs b/ghc/lib/required/Ix.lhs index c68546f..afafe24 100644 --- a/ghc/lib/required/Ix.lhs +++ b/ghc/lib/required/Ix.lhs @@ -7,12 +7,13 @@ \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module Ix ( - Ix(range, index, inRange) - ) where +module Ix + ( + Ix(range, index, inRange), + rangeSize + ) where import {-# SOURCE #-} IOBase ( error ) -import PrelNum import PrelTup import PrelBase \end{code} @@ -42,7 +43,10 @@ instance Ix Char where range (c,c') = [c..c'] index b@(c,c') ci | inRange b ci = fromEnum ci - fromEnum c - | otherwise = error "LibIx.index: Index out of range." + | otherwise = error (showString "Ix{Char}.index: Index " . + showParen True (showsPrec 0 ci) . + showString " out of range " $ + showParen True (showsPrec 0 b) "") inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c' where i = fromEnum ci @@ -50,15 +54,13 @@ instance Ix Int where range (m,n) = [m..n] index b@(m,n) i | inRange b i = i - m - | otherwise = error "LibIx.index: Index out of range." + | otherwise = error (showString "Ix{Int}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 b) "") inRange (m,n) i = m <= i && i <= n -instance Ix Integer where - range (m,n) = [m..n] - index b@(m,n) i - | inRange b i = fromInteger (i - m) - | otherwise = error "LibIx.index: Index out of range." - inRange (m,n) i = m <= i && i <= n +-- Integer instance is in PrelNum ---------------------------------------------------------------------- instance Ix Bool where -- as derived @@ -72,7 +74,6 @@ instance Ix Ordering where -- as derived index (l,u) i = fromEnum i - fromEnum l inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u - ---------------------------------------------------------------------- instance Ix () where {-# INLINE range #-} @@ -85,16 +86,16 @@ instance Ix () where ---------------------------------------------------------------------- instance (Ix a, Ix b) => Ix (a, b) where -- as derived {-# INLINE range #-} - range ((l1,l2),(u1,u2)) - = [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + range ((l1,l2),(u1,u2)) = + [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] {-# INLINE index #-} - index ((l1,l2),(u1,u2)) (i1,i2) - = index (l1,u1) i1 * (index (l2,u2) u2 + (I# 1#)){-rangeSize (l2,u2)-} + index (l2,u2) i2 + index ((l1,l2),(u1,u2)) (i1,i2) = + index (l1,u1) i1 * rangeSize (l2,u2) + index (l2,u2) i2 {-# INLINE inRange #-} - inRange ((l1,l2),(u1,u2)) (i1,i2) - = inRange (l1,u1) i1 && inRange (l2,u2) i2 + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where range ((l1,l2,l3),(u1,u2,u3)) = @@ -104,52 +105,62 @@ instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = index (l3,u3) i3 + rangeSize (l3,u3) * ( - index (l2,u2) i2 + rangeSize (l2,u2) * ( - index (l1,u1) i1)) - where - rangeSize (l,u) = index (l,u) u + (1 :: Int) + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1)) inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = - [(i1,i2,i3,i4) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4)] + [(i1,i2,i3,i4) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4)] index ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = index (l4,u4) i4 + rangeSize (l4,u4) * ( - index (l3,u3) i3 + rangeSize (l3,u3) * ( - index (l2,u2) i2 + rangeSize (l2,u2) * ( - index (l1,u1) i1))) - where - rangeSize (l,u) = index (l,u) u + (1 :: Int) + index (l3,u3) i3 + rangeSize (l3,u3) * ( + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1))) inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = - [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4), - i5 <- range (l5,u5)] + [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4), + i5 <- range (l5,u5)] index ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = index (l5,u5) i5 + rangeSize (l5,u5) * ( - index (l4,u4) i4 + rangeSize (l4,u4) * ( - index (l3,u3) i3 + rangeSize (l3,u3) * ( - index (l2,u2) i2 + rangeSize (l2,u2) * ( - index (l1,u1) i1)))) - where - rangeSize (l,u) = index (l,u) u + (1 :: Int) + index (l4,u4) i4 + rangeSize (l4,u4) * ( + index (l3,u3) i3 + rangeSize (l3,u3) * ( + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1)))) inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 && inRange (l5,u5) i5 + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 && + inRange (l5,u5) i5 +\end{code} + +%******************************************************** +%* * +\subsection{Size of @Ix@ interval} +%* * +%******************************************************** + +The @rangeSize@ operator returns the number of elements +in the range for an @Ix@ pair: + +\begin{code} +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize b@(_,high) = index b high + 1 + \end{code} diff --git a/ghc/lib/required/List.lhs b/ghc/lib/required/List.lhs index 0260393..b2b3baf 100644 --- a/ghc/lib/required/List.lhs +++ b/ghc/lib/required/List.lhs @@ -6,21 +6,31 @@ \begin{code} module List ( - delete, deleteBy, (\\), deleteFirsts, deleteFirstsBy, - elemBy, notElemBy, lookupBy, maximumBy, minimumBy, - nub, nubBy, partition, sums, products, transpose, + elemIndex, elemIndices, + find, findIndex, findIndices, + nub, nubBy, delete, deleteBy, (\\), union, intersect, + intersperse, transpose, partition, + mapAccumL, mapAccumR, + sort, sortBy, insertBy, + maximumBy, minimumBy, + genericLength, genericTake, genericDrop, + genericSplitAt, genericIndex, zip4, zip5, zip6, zip7, zipWith4, zipWith5, zipWith6, zipWith7, - unzip4, unzip5, unzip6, unzip7, - genericLength, genericDrop, genericTake, genericSplitAt, - genericReplicate, - elemIndex, elemIndexBy, intersperse, group, groupBy, - mapAccumL, mapAccumR, - inits, tails, subsequences, permutations, - union, intersect + unzip4, unzip5, unzip6, unzip7 + +{- Disappeared from 1.4 libs - include still? + sums, products, + elemIndexBy, group, groupBy, + inits, tails, subsequences, permutations +-} + ) where import Prelude +import Maybe (listToMaybe) + +infix 5 \\ \end{code} %********************************************************* @@ -30,6 +40,29 @@ import Prelude %********************************************************* \begin{code} +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) + +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) + +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +findIndices :: (a -> Bool) -> [a] -> [Int] +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] + +-- nub (meaning "essence") remove duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +nub = nubBy (==) + +nubBy :: (a -> a -> Bool) -> [a] -> [a] +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) + -- delete x removes the first occurrence of x from its list argument. delete :: (Eq a) => a -> [a] -> [a] delete = deleteBy (==) @@ -44,25 +77,61 @@ deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys (\\) :: (Eq a) => [a] -> [a] -> [a] (\\) = foldl (flip delete) --- Alternate name for \\ -deleteFirsts :: (Eq a) => [a] -> [a] -> [a] -deleteFirsts = (\\) +-- List union, remove the elements of first list from second. +union :: (Eq a) => [a] -> [a] -> [a] +union xs ys = xs ++ (ys \\ xs) -deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] -deleteFirstsBy eq = foldl (flip (deleteBy eq)) +intersect :: (Eq a) => [a] -> [a] -> [a] +intersect xs ys = [ x | x <- xs, x `elem` ys] --- elem, notElem, lookup, maximumBy and minimumBy are in PreludeList -elemBy, notElemBy :: (a -> a -> Bool) -> a -> [a] -> Bool -elemBy eq _ [] = False -elemBy eq x (y:ys) = x `eq` y || elemBy eq x ys +-- intersperse sep inserts sep between the elements of its list argument. +-- e.g. intersperse ',' "abcde" == "a,b,c,d,e" +intersperse :: a -> [a] -> [a] +intersperse sep [] = [] +intersperse sep [x] = [x] +intersperse sep (x:xs) = x : sep : intersperse sep xs -notElemBy eq x xs = not (elemBy eq x xs) +transpose :: [[a]] -> [[a]] +transpose = foldr + (\xs xss -> zipWith (:) xs (xss ++ repeat [])) + [] -lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b -lookupBy eq key [] = Nothing -lookupBy eq key ((x,y):xys) - | key `eq` x = Just y - | otherwise = lookupBy eq key xys + +-- partition takes a predicate and a list and returns a pair of lists: +-- those elements of the argument list that do and do not satisfy the +-- predicate, respectively; i,e,, +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p xs = foldr select ([],[]) xs + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) + + + + +mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumL f s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs + +mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) +mapAccumR f s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs +sort :: (Ord a) => [a] -> [a] +sort = sortBy compare + +sortBy :: (a -> a -> Ordering) -> [a] -> [a] +sortBy cmp = foldr (insertBy cmp) [] + +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy cmp 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" @@ -72,33 +141,36 @@ minimumBy :: (a -> a -> a) -> [a] -> a minimumBy min [] = error "List.minimumBy: empty list" minimumBy min xs = foldl1 min xs --- nub (meaning "essence") remove duplicate elements from its list argument. -nub :: (Eq a) => [a] -> [a] -nub = nubBy (==) +genericLength :: (Num i) => [b] -> i +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l -nubBy :: (a -> a -> Bool) -> [a] -> [a] -nubBy eq [] = [] -nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) +genericTake :: (Integral i) => i -> [a] -> [a] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs +genericTake _ _ = error "List.genericTake: negative argument" --- partition takes a predicate and a list and returns a pair of lists: --- those elements of the argument list that do and do not satisfy the --- predicate, respectively; i,e,, --- partition p xs == (filter p xs, filter (not . p) xs). -partition :: (a -> Bool) -> [a] -> ([a],[a]) -partition p xs = foldr select ([],[]) xs - where select x (ts,fs) | p x = (x:ts,fs) - | otherwise = (ts, x:fs) +genericDrop :: (Integral i) => i -> [a] -> [a] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs +genericDrop _ _ = error "List.genericDrop: negative argument" --- sums and products give a list of running sums or products from --- a list of numbers. e.g., sums [1,2,3] == [0,1,3,6] -sums, products :: (Num a) => [a] -> [a] -sums = scanl (+) 0 -products = scanl (*) 1 +genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where + (xs',xs'') = genericSplitAt (n-1) xs +genericSplitAt _ _ = error "List.genericSplitAt: negative argument" -transpose :: [[a]] -> [[a]] -transpose = foldr - (\xs xss -> zipWith (:) xs (xss ++ repeat [])) - [] + +genericIndex :: (Integral a) => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument." +genericIndex _ _ = error "List.genericIndex: index too large." zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] zip4 = zipWith4 (,,,) @@ -157,36 +229,35 @@ unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) ([],[],[],[],[],[],[]) -genericLength :: (Num i) => [b] -> i -genericLength [] = 0 -genericLength (_:l) = 1 + genericLength l -genericDrop :: (Integral i) => i -> [a] -> [a] -genericDrop 0 xs = xs -genericDrop _ [] = [] -genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs -genericDrop _ _ = error "List.genericDrop: negative argument" -genericTake :: (Integral i) => i -> [a] -> [a] -genericTake 0 _ = [] -genericTake _ [] = [] -genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs -genericTake _ _ = error "List.genericTake: negative argument" +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) -genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) -genericSplitAt 0 xs = ([],xs) -genericSplitAt _ [] = ([],[]) -genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where - (xs',xs'') = genericSplitAt (n-1) xs -genericSplitAt _ _ = error "List.genericSplitAt: negative argument" +-- elem, notElem, lookup, maximumBy and minimumBy are in PreludeList +elemBy, notElemBy :: (a -> a -> Bool) -> a -> [a] -> Bool +elemBy eq _ [] = False +elemBy eq x (y:ys) = x `eq` y || elemBy eq x ys + +notElemBy eq x xs = not (elemBy eq x xs) + +lookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b +lookupBy eq key [] = Nothing +lookupBy eq key ((x,y):xys) + | key `eq` x = Just y + | otherwise = lookupBy eq key xys + + +-- sums and products give a list of running sums or products from +-- a list of numbers. e.g., sums [1,2,3] == [0,1,3,6] +sums, products :: (Num a) => [a] -> [a] +sums = scanl (+) 0 +products = scanl (*) 1 genericReplicate :: (Integral i) => i -> a -> [a] genericReplicate n x = genericTake n (repeat x) --- l !! (elemIndex l x) == x if x `elem` l -elemIndex :: Eq a => [a] -> a -> Int -elemIndex = elemIndexBy (==) - +{- elemIndexBy :: (a -> a -> Bool) -> [a] -> a -> Int elemIndexBy eq [] x = error "List.elemIndexBy: empty list" elemIndexBy eq (x:xs) x' = if x `eq` x' then 0 else 1 + elemIndexBy eq xs x' @@ -201,26 +272,6 @@ groupBy :: (a -> a -> Bool) -> [a] -> [[a]] groupBy eq [] = [] groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs - - -mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) -mapAccumL f s [] = (s, []) -mapAccumL f s (x:xs) = (s'',y:ys) - where (s', y ) = f s x - (s'',ys) = mapAccumL f s' xs - -mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c]) -mapAccumR f s [] = (s, []) -mapAccumR f s (x:xs) = (s'', y:ys) - where (s'',y ) = f s' x - (s', ys) = mapAccumR f s xs - --- 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 sep (x:xs) = x : sep : intersperse sep xs -- inits xs returns the list of initial segments of xs, shortest first. -- e.g., inits "abc" == ["","a","ab","abc"] @@ -248,10 +299,5 @@ permutations (x:xs) = [zs | ys <- permutations xs, zs <- interleave x ys ] where interleave :: a -> [a] -> [[a]] interleave x [] = [[x]] interleave x (y:ys) = [x:y:ys] ++ map (y:) (interleave x ys) - -union :: (Eq a) => [a] -> [a] -> [a] -union xs ys = xs ++ (ys \\ xs) - -intersect :: (Eq a) => [a] -> [a] -> [a] -intersect xs ys = [x | x <- xs, x `elem` ys] +-} \end{code} diff --git a/ghc/lib/required/Maybe.lhs b/ghc/lib/required/Maybe.lhs index 1acead7..bd9d1b9 100644 --- a/ghc/lib/required/Maybe.lhs +++ b/ghc/lib/required/Maybe.lhs @@ -1,17 +1,24 @@ % % (c) The AQUA Project, Glasgow University, 1994-1996 % - \section[Maybe]{Module @Maybe@} +The standard Haskell 1.3 library for working with +@Maybe@ values. + \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module Maybe( +module Maybe + ( Maybe(..), - the, exists, theExists, maybe, fromMaybe, listToMaybe, maybeToList, - findMaybe, catMaybes, mapMaybe, joinMaybe, unfoldr - ) where + isJust, fromJust, + fromMaybe, + listToMaybe, maybeToList, + catMaybes, + mapMaybe, + unfoldr + ) where import IOBase ( error ) import Monad ( filter ) @@ -27,55 +34,70 @@ import PrelBase %********************************************************* \begin{code} -maybe :: b -> (a -> b) -> Maybe a -> b -maybe n f Nothing = n -maybe n f (Just x) = f x - -exists :: Maybe a -> Bool -exists = maybe False (const True) +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust _ = True -the :: Maybe a -> a -the = maybe (error "Maybe.the: Nothing") id +fromJust :: Maybe a -> a +fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck +fromJust (Just x) = x -theExists :: Maybe a -> (a, Bool) -theExists Nothing = (error "Maybe.theExists: Nothing", False) -theExists (Just x) = (x, True) - -fromMaybe :: a -> Maybe a -> a -fromMaybe d = maybe d id +fromMaybe :: a -> Maybe a -> a +fromMaybe d x = case x of {Nothing -> d;Just v -> v} maybeToList :: Maybe a -> [a] -maybeToList = maybe [] (\ x -> [x]) +maybeToList Nothing = [] +maybeToList (Just x) = [x] -listToMaybe :: [a] -> Maybe a -listToMaybe [] = Nothing -listToMaybe (a:as) = Just a +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a findMaybe :: (a -> Bool) -> [a] -> Maybe a findMaybe p = listToMaybe . filter p catMaybes :: [Maybe a] -> [a] -catMaybes [] = [] -catMaybes (Nothing:xs) = catMaybes xs -catMaybes (Just x:xs) = x : catMaybes xs - -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe f = catMaybes . map f - -joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +catMaybes ls = [x | Just x <- ls] + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f [] = [] +mapMaybe f (x:xs) = + let rs = mapMaybe f xs in + case f x of + Nothing -> rs + Just r -> r:rs + +--OLD: mapMaybe f = catMaybes . map f +-- new version is potentially more space efficient + +-- 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)} + +{- OLD: Note: stricter than the above. joinMaybe _ Nothing Nothing = Nothing joinMaybe _ (Just g) Nothing = Just g joinMaybe _ Nothing (Just g) = Just g joinMaybe f (Just g) (Just h) = Just (f g h) +-} --- unfoldr f' (foldr f z xs) == (xs,z) --- --- if the following holds: --- --- f' (f x y) = Just (x,y) --- f' z = Nothing -unfoldr :: (a -> Maybe (b, a)) -> a -> ([b],a) -unfoldr f x = +\end{code} + +\begin{verbatim} + unfoldr f' (foldr f z xs) == (xs,z) + + if the following holds: + + f' (f x y) = Just (x,y) + f' z = Nothing +\end{verbatim} + +\begin{code} +unfoldr :: (a -> Maybe (b, a)) -> a -> ([b],a) +unfoldr f x = case f x of Just (y,x') -> let (ys,x'') = unfoldr f x' in (y:ys,x'') Nothing -> ([],x) diff --git a/ghc/lib/required/Monad.lhs b/ghc/lib/required/Monad.lhs index dfc82e5..6389b91 100644 --- a/ghc/lib/required/Monad.lhs +++ b/ghc/lib/required/Monad.lhs @@ -1,21 +1,30 @@ % % (c) The AQUA Project, Glasgow University, 1994-1996 % - \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, - - -- Other monad functions - join, mapAndUnzipM, zipWithM, foldM, when, unless, ap, unless, when, - liftM, liftM2, liftM3, liftM4, liftM5 + 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] + 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 import PrelList @@ -87,6 +96,9 @@ unless p s = if p then return () else s when :: (Monad m) => Bool -> m () -> m () when p s = if p then s else return () +ap :: (Monad m) => m (a->b) -> m a -> m b +ap = liftM2 ($) + liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r @@ -99,7 +111,4 @@ liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } -ap :: (Monad m) => m (a->b) -> m a -> m b -ap = liftM2 ($) - \end{code} diff --git a/ghc/lib/required/Prelude.lhs b/ghc/lib/required/Prelude.lhs index 0167b0c..2870fa9 100644 --- a/ghc/lib/required/Prelude.lhs +++ b/ghc/lib/required/Prelude.lhs @@ -31,9 +31,6 @@ module Prelude ( Functor(..), Monad(..), MonadZero(..), MonadPlus(..), accumulate, sequence, mapM, mapM_, guard, filter, concat, applyM, - -- From Maybe - maybe, - -- From PrelRead ReadS, Read(readsPrec, readList), reads, read, lex, readParen, @@ -67,6 +64,7 @@ import PrelTup import Monad import Maybe import IOBase ( error ) +import GHCerr -- These can't conveniently be defined in PrelBase because they use numbers, -- or I/O, so here's a convenient place to do them. diff --git a/ghc/lib/required/System.lhs b/ghc/lib/required/System.lhs index 1bdaa1f..bdf6ad3 100644 --- a/ghc/lib/required/System.lhs +++ b/ghc/lib/required/System.lhs @@ -12,9 +12,10 @@ module System ( import Prelude import Foreign ( Addr ) -import IOBase ( IOError(..), thenIO_Prim, constructErrorAndFail ) +import IOBase ( IOError(..), IOErrorType(..), thenIO_Prim, constructErrorAndFail ) import ArrBase ( indexAddrOffAddr ) import PackedString ( unpackCString ) + \end{code} %********************************************************* @@ -80,7 +81,7 @@ getEnv name = if litstring /= ``NULL'' then return (unpackCString litstring) else - fail (NoSuchThing ("environment variable: " ++ name)) + fail (IOError Nothing NoSuchThing ("environment variable: " ++ name)) \end{code} Computation $system cmd$ returns the exit code @@ -97,7 +98,7 @@ The implementation does not support system calls. \end{itemize} \begin{code} -system "" = fail (InvalidArgument "null command") +system "" = fail (IOError Nothing InvalidArgument "null command") system cmd = _ccall_ systemCmd cmd `thenIO_Prim` \ status -> case status of @@ -114,13 +115,13 @@ Before it terminates, any open or semi-closed handles are first closed. \begin{code} exitWith ExitSuccess = _ccall_ EXIT (0::Int) `thenIO_Prim` \ () -> - fail (OtherError "exit should not return") + fail (IOError Nothing OtherError "exit should not return") exitWith (ExitFailure n) - | n == 0 = fail (InvalidArgument "ExitFailure 0") + | n == 0 = fail (IOError Nothing InvalidArgument "ExitFailure 0") | otherwise = _ccall_ EXIT n `thenIO_Prim` \ () -> - fail (OtherError "exit should not return") + fail (IOError Nothing OtherError "exit should not return") \end{code}