%
-% (c) The AQUA Project, Glasgow University, 1994-1997
+% (c) The AQUA Project, Glasgow University, 1994-1999
%
\section[Directory]{Directory interface}
{-# OPTIONS -#include <sys/stat.h> -#include <dirent.h> -#include "cbits/stgio.h" #-}
module Directory
(
- Permissions(Permissions),
-
- createDirectory,
- removeDirectory,
- renameDirectory,
- getDirectoryContents,
- getCurrentDirectory,
- setCurrentDirectory,
-
- removeFile,
- renameFile,
-
- doesFileExist,
- doesDirectoryExist,
- getPermissions,
- setPermissions,
- getModificationTime
- ) where
+ Permissions -- abstract
+
+ , readable -- :: Permissions -> Bool
+ , writable -- :: Permissions -> Bool
+ , executable -- :: Permissions -> Bool
+ , searchable -- :: Permissions -> Bool
-import PrelBase
-import PrelIOBase
-import PrelST
-import PrelArr
-import PrelPack ( unpackNBytesST )
-import PrelCCall ( Word(..) )
-import PrelAddr
-import Time ( ClockTime(..) )
+ , createDirectory -- :: FilePath -> IO ()
+ , removeDirectory -- :: FilePath -> IO ()
+ , renameDirectory -- :: FilePath -> FilePath -> IO ()
-\end{code}
+ , getDirectoryContents -- :: FilePath -> IO [FilePath]
+ , getCurrentDirectory -- :: IO FilePath
+ , setCurrentDirectory -- :: FilePath -> IO ()
-%*********************************************************
-%* *
-\subsection{Signatures}
-%* *
-%*********************************************************
+ , removeFile -- :: FilePath -> IO ()
+ , renameFile -- :: FilePath -> FilePath -> IO ()
-\begin{code}
-createDirectory :: FilePath -> IO ()
-removeDirectory :: FilePath -> IO ()
-removeFile :: FilePath -> IO ()
-renameDirectory :: FilePath -> FilePath -> IO ()
-renameFile :: FilePath -> FilePath -> IO ()
-getDirectoryContents :: FilePath -> IO [FilePath]
-getCurrentDirectory :: IO FilePath
-setCurrentDirectory :: FilePath -> IO ()
-doesFileExist :: FilePath -> IO Bool
-doesDirectoryExist :: FilePath -> IO Bool
-getPermissions :: FilePath -> IO Permissions
-setPermissions :: FilePath -> Permissions -> IO ()
-getModificationTime :: FilePath -> IO ClockTime
-\end{code}
+ , doesFileExist -- :: FilePath -> IO Bool
+ , doesDirectoryExist -- :: FilePath -> IO Bool
+
+ , getPermissions -- :: FilePath -> IO Permissions
+ , setPermissions -- :: FilePath -> Permissions -> IO ()
+
+
+#ifndef __HUGS__
+ , getModificationTime -- :: FilePath -> IO ClockTime
+#endif
+ ) where
+
+#ifdef __HUGS__
+--import PreludeBuiltin
+#else
+
+import Prelude -- Just to get it in the dependencies
+
+import PrelGHC ( RealWorld, int2Word#, or#, and# )
+import PrelByteArr ( ByteArray, MutableByteArray,
+ newWordArray, readWordArray, newCharArray,
+ unsafeFreezeByteArray
+ )
+import PrelPack ( unpackNBytesST, packString, unpackCStringST )
+import PrelIOBase ( stToIO,
+ constructErrorAndFail, constructErrorAndFailWithInfo,
+ IOError(IOError), IOErrorType(SystemError) )
+import Time ( ClockTime(..) )
+import PrelAddr ( Addr, nullAddr, Word(..), wordToInt )
+#endif
+\end{code}
%*********************************************************
%* *
\begin{code}
data Permissions
= Permissions {
- readable, writeable,
+ readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
\end{code}
\end{itemize}
\begin{code}
+createDirectory :: FilePath -> IO ()
createDirectory path = do
- rc <- _ccall_ createDirectory path
+ rc <- primCreateDirectory (primPackString path)
if rc == 0 then return () else
constructErrorAndFailWithInfo "createDirectory" path
\end{code}
\end{itemize}
\begin{code}
+removeDirectory :: FilePath -> IO ()
removeDirectory path = do
- rc <- _ccall_ removeDirectory path
+ rc <- primRemoveDirectory (primPackString path)
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
+removeFile :: FilePath -> IO ()
removeFile path = do
- rc <- _ccall_ removeFile path
+ rc <- primRemoveFile (primPackString path)
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
+renameDirectory :: FilePath -> FilePath -> IO ()
renameDirectory opath npath = do
- rc <- _ccall_ renameDirectory opath npath
+ rc <- primRenameDirectory (primPackString opath) (primPackString npath)
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
+renameFile :: FilePath -> FilePath -> IO ()
renameFile opath npath = do
- rc <- _ccall_ renameFile opath npath
+ rc <- primRenameFile (primPackString opath) (primPackString npath)
if rc == 0 then
return ()
else
\end{itemize}
\begin{code}
---getDirectoryContents :: FilePath -> IO [FilePath]
+getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
- dir <- _ccall_ openDir__ path
- if dir == ``NULL''
+ dir <- primOpenDir (primPackString path)
+ if dir == nullAddr
then constructErrorAndFailWithInfo "getDirectoryContents" path
else loop dir
where
loop :: Addr -> IO [String]
loop dir = do
- dirent_ptr <- _ccall_ readDir__ dir
- if (dirent_ptr::Addr) == ``NULL''
+ dirent_ptr <- primReadDir dir
+ if dirent_ptr == nullAddr
then do
-- readDir__ implicitly performs closedir() when the
-- end is reached.
return []
else do
- str <- _casm_ `` %r=(char*)((struct dirent*)%0)->d_name; '' dirent_ptr
- -- not using the unpackCString function here, since we have to force
- -- the unmarshalling of the directory entry right here as subsequent
- -- calls to readdir() may overwrite it.
- len <- _ccall_ strlen str
- entry <- stToIO (unpackNBytesST str len)
+ str <- primGetDirentDName dirent_ptr
+ entry <- primUnpackCString str
entries <- loop dir
return (entry:entries)
\end{code}
\end{itemize}
\begin{code}
+getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
- str <- _ccall_ getCurrentDirectory
- if str /= ``NULL''
+ str <- primGetCurrentDirectory
+ if str /= nullAddr
then do
- len <- _ccall_ strlen str
- pwd <- stToIO (unpackNBytesST str len)
- _ccall_ free str
+ pwd <- primUnpackCString str
+ primFree str
return pwd
else
constructErrorAndFail "getCurrentDirectory"
\end{itemize}
\begin{code}
+setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
- rc <- _ccall_ setCurrentDirectory path
+ rc <- primSetCurrentDirectory (primPackString path)
if rc == 0
then return ()
else constructErrorAndFailWithInfo "setCurrentDirectory" path
\end{code}
+To clarify, @doesDirectoryExist@ returns True if a file system object
+exist, and it's a directory. @doesFileExist@ returns True if the file
+system object exist, but it's not a directory (i.e., for every other
+file system object that is not a directory.)
\begin{code}
---doesFileExist :: FilePath -> IO Bool
+doesDirectoryExist :: FilePath -> IO Bool
+doesDirectoryExist name =
+ catch
+ (getFileStatus name >>= \ st -> return (isDirectory st))
+ (\ _ -> return False)
+
+doesFileExist :: FilePath -> IO Bool
doesFileExist name = do
- rc <- _ccall_ access name (``F_OK''::Int)
- return (rc == 0)
+ catch
+ (getFileStatus name >>= \ st -> return (not (isDirectory st)))
+ (\ _ -> return False)
---doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- (getFileStatus name >>= \ st -> return (isDirectory st))
- `catch`
- (\ _ -> return False)
+foreign import ccall "libHS_cbits.so" "const_F_OK" unsafe const_F_OK :: Int
---getModificationTime :: FilePath -> IO ClockTime
+#ifndef __HUGS__
+getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
getFileStatus name >>= \ st ->
modificationTime st
+#endif
---getPermissions :: FilePath -> IO Permissions
-getPermissions name =
- getFileStatus name >>= \ st ->
+getPermissions :: FilePath -> IO Permissions
+getPermissions name = do
+ st <- getFileStatus name
let
fm = fileMode st
isect v = intersectFileMode v fm == v
- in
+
return (
Permissions {
readable = isect ownerReadMode,
- writeable = isect ownerWriteMode,
+ writable = isect ownerWriteMode,
executable = not (isDirectory st) && isect ownerExecuteMode,
searchable = not (isRegularFile st) && isect ownerExecuteMode
}
- )
+ )
---setPermissions :: FilePath -> Permissions -> IO ()
+setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
- read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# }
- write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# }
- exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# }
+ read = if r then ownerReadMode else emptyFileMode
+ write = if w then ownerWriteMode else emptyFileMode
+ exec = if e || s then ownerExecuteMode else emptyFileMode
- mode = I# (word2Int# (read# `or#` write# `or#` exec#))
+ mode = read `unionFileMode` (write `unionFileMode` exec)
- rc <- _ccall_ chmod name mode
+ rc <- primChmod (primPackString name) mode
if rc == 0
then return ()
- else fail (IOError Nothing SystemError "setPermissions" "insufficient permissions")
-
+ else ioError (IOError Nothing SystemError "setPermissions" "insufficient permissions")
\end{code}
-
(Sigh)..copied from Posix.Files to avoid dep. on posix library
\begin{code}
-type FileStatus = ByteArray Int
+type FileStatus = PrimByteArray
getFileStatus :: FilePath -> IO FileStatus
getFileStatus name = do
- bytes <- stToIO (newCharArray (0,``sizeof(struct stat)''))
- rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' name bytes
+ bytes <- primNewByteArray sizeof_stat
+ rc <- primStat (primPackString name) bytes
if rc == 0
+#ifdef __HUGS__
+ then primUnsafeFreezeByteArray bytes
+#else
then stToIO (unsafeFreezeByteArray bytes)
- else fail (IOError Nothing SystemError "getFileStatus" "")
+#endif
+ else ioError (IOError Nothing SystemError "getFileStatus" "")
+#ifndef __HUGS__
modificationTime :: FileStatus -> IO ClockTime
modificationTime stat = do
- i1 <- malloc1
- _casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1
- secs <- cvtUnsigned i1
- return (TOD secs 0)
- where
- malloc1 = IO $ \ s# ->
- case newIntArray# 1# s# of
- StateAndMutableByteArray# s2# barr# ->
- IOok s2# (MutableByteArray bnds barr#)
-
- bnds = (0,1)
- -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,'
- -- so we freeze the data bits and use them for an MP_INT structure. Note that
- -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
- -- acceptable to gmp.
-
- cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# ->
- case readIntArray# arr# 0# s# of
- StateAndInt# s2# r# ->
- if r# ==# 0# then
- IOok s2# 0
- else
- case unsafeFreezeByteArray# arr# s2# of
- StateAndByteArray# s3# frozen# ->
- IOok s3# (J# 1# 1# frozen#)
+ i1 <- stToIO (newWordArray (0,1))
+ setFileMode i1 stat
+ secs <- stToIO (readWordArray i1 0)
+ return (TOD (toInteger (wordToInt secs)) 0)
+
+foreign import ccall "libHS_cbits.so" "set_stat_st_mtime" unsafe
+ setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO ()
+#endif
isDirectory :: FileStatus -> Bool
-isDirectory stat = unsafePerformIO $ do
- rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
- return (rc /= 0)
+isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0
isRegularFile :: FileStatus -> Bool
-isRegularFile stat = unsafePerformIO $ do
- rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
- return (rc /= 0)
+isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0
+
+foreign import ccall "libHS_cbits.so" "sizeof_stat" unsafe sizeof_stat :: Int
+foreign import ccall "libHS_cbits.so" "prim_stat" unsafe
+ primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
+
+foreign import ccall "libHS_cbits.so" "get_stat_st_mode" unsafe fileMode :: FileStatus -> FileMode
+foreign import ccall "libHS_cbits.so" "prim_S_ISDIR" unsafe prim_S_ISDIR :: FileMode -> Int
+foreign import ccall "libHS_cbits.so" "prim_S_ISREG" unsafe prim_S_ISREG :: FileMode -> Int
\end{code}
\begin{code}
type FileMode = Word
-ownerReadMode :: FileMode
-ownerReadMode = ``S_IRUSR''
-ownerWriteMode :: FileMode
-ownerWriteMode = ``S_IWUSR''
+emptyFileMode :: FileMode
+unionFileMode :: FileMode -> FileMode -> FileMode
+intersectFileMode :: FileMode -> FileMode -> FileMode
-ownerExecuteMode :: FileMode
-ownerExecuteMode = ``S_IXUSR''
+foreign import ccall "libHS_cbits.so" "const_S_IRUSR" unsafe ownerReadMode :: FileMode
+foreign import ccall "libHS_cbits.so" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode
+foreign import ccall "libHS_cbits.so" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode
+
+#ifdef __HUGS__
+emptyFileMode = primIntToWord 0
+unionFileMode = primOrWord
+intersectFileMode = primAndWord
+#else
+--ToDo: tidy up.
+emptyFileMode = W# (int2Word# 0#)
+unionFileMode = orWord
+intersectFileMode = andWord
+#endif
-intersectFileMode :: FileMode -> FileMode -> FileMode
-intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
+\end{code}
-fileMode :: FileStatus -> FileMode
-fileMode stat = unsafePerformIO (
- _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat)
+Some defns. to allow us to share code.
+\begin{code}
+#ifndef __HUGS__
+
+primPackString :: [Char] -> ByteArray Int
+primPackString = packString
+--ToDo: fix.
+primUnpackCString :: Addr -> IO String
+primUnpackCString a = stToIO (unpackCStringST a)
+
+type PrimByteArray = ByteArray Int
+type PrimMutableByteArray s = MutableByteArray RealWorld Int
+type CString = PrimByteArray
+
+orWord, andWord :: Word -> Word -> Word
+orWord (W# x#) (W# y#) = W# (x# `or#` y#)
+andWord (W# x#) (W# y#) = W# (x# `and#` y#)
+
+primNewByteArray :: Int -> IO (PrimMutableByteArray s)
+primNewByteArray sz_in_bytes = stToIO (newCharArray (0,sz_in_bytes))
+#endif
+
+foreign import ccall "libHS_cbits.so" "createDirectory" unsafe primCreateDirectory :: CString -> IO Int
+foreign import ccall "libHS_cbits.so" "removeDirectory" unsafe primRemoveDirectory :: CString -> IO Int
+foreign import ccall "libHS_cbits.so" "removeFile" unsafe primRemoveFile :: CString -> IO Int
+foreign import ccall "libHS_cbits.so" "renameDirectory" unsafe primRenameDirectory :: CString -> CString -> IO Int
+foreign import ccall "libHS_cbits.so" "renameFile" unsafe primRenameFile :: CString -> CString -> IO Int
+foreign import ccall "libHS_cbits.so" "openDir__" unsafe primOpenDir :: CString -> IO Addr
+foreign import ccall "libHS_cbits.so" "readDir__" unsafe primReadDir :: Addr -> IO Addr
+foreign import ccall "libHS_cbits.so" "get_dirent_d_name" unsafe primGetDirentDName :: Addr -> IO Addr
+foreign import ccall "libHS_cbits.so" "setCurrentDirectory" unsafe primSetCurrentDirectory :: CString -> IO Int
+foreign import ccall "libHS_cbits.so" "getCurrentDirectory" unsafe primGetCurrentDirectory :: IO Addr
+foreign import ccall "libc.so.6" "free" unsafe primFree :: Addr -> IO ()
+foreign import ccall "libc.so.6" "malloc" unsafe primMalloc :: Word -> IO Addr
+foreign import ccall "libc.so.6" "chmod" unsafe primChmod :: CString -> Word -> IO Int
\end{code}
+
projects / ghc-hetmet.git / blobdiff