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
%*********************************************************
\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'
\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}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1997
%
\section[Complex]{Module @Complex@}
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1997
%
\section[Directory]{Module @Directory@}
\begin{code}
module Directory (
+-- Permissions(Permissions),
createDirectory, removeDirectory, removeFile,
renameDirectory, renameFile, getDirectoryContents,
getCurrentDirectory, setCurrentDirectory
+{-
+ ,doesFileExist, doesDirectoryExist,
+ getPermissions, setPermissions,
+ getModificationTime
+-}
) where
import Prelude
%*********************************************************
%* *
-\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}
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
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}
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
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}
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
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}
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
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}
constructErrorAndFail "renameFile"
\end{code}
-$getDirectoryContents dir$ returns a list of
-<i>all</i> 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}
\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}
\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}
\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}
\section[IO]{Module @IO@}
\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
module IO (
Handle, HandlePosn,
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
import PackedString ( nilPS, packCBytesST, unpackPS )
import PrelBase
import GHC
+import Foreign ( makeForeignObj )
\end{code}
%*********************************************************
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
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) >>
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) >>
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) >>
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,
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
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 >>
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 >>
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 ""
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) >>
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
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
{-
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#) ->
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 ->
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}
\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}
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
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
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 #-}
----------------------------------------------------------------------
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)) =
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}
\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}
%*********************************************************
%*********************************************************
\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 (==)
(\\) :: (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"
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 (,,,)
(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'
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"]
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}
%
% (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 )
%*********************************************************
\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)
%
% (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
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
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}
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,
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.
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}
%*********************************************************
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
\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
\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}
projects / ghc-hetmet.git / commitdiff