) where
-import System.Directory.Internals
import Control.Monad
import Data.Bits
import Data.Maybe
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
- filepath = tmp_dir `joinFileName` filename
+ filepath = tmp_dir ++ [pathSeparator] ++ filename
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Directory
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- System-independent interface to directory manipulation.
---
------------------------------------------------------------------------------
-
-module System.Directory
- (
- -- $intro
-
- -- * Actions on directories
- createDirectory -- :: FilePath -> IO ()
- , createDirectoryIfMissing -- :: Bool -> FilePath -> IO ()
- , removeDirectory -- :: FilePath -> IO ()
- , removeDirectoryRecursive -- :: FilePath -> IO ()
- , renameDirectory -- :: FilePath -> FilePath -> IO ()
-
- , getDirectoryContents -- :: FilePath -> IO [FilePath]
- , getCurrentDirectory -- :: IO FilePath
- , setCurrentDirectory -- :: FilePath -> IO ()
-
- -- * Pre-defined directories
- , getHomeDirectory
- , getAppUserDataDirectory
- , getUserDocumentsDirectory
- , getTemporaryDirectory
-
- -- * Actions on files
- , removeFile -- :: FilePath -> IO ()
- , renameFile -- :: FilePath -> FilePath -> IO ()
- , copyFile -- :: FilePath -> FilePath -> IO ()
-
- , canonicalizePath
- , findExecutable
-
- -- * Existence tests
- , doesFileExist -- :: FilePath -> IO Bool
- , doesDirectoryExist -- :: FilePath -> IO Bool
-
- -- * Permissions
-
- -- $permissions
-
- , Permissions(
- Permissions,
- readable, -- :: Permissions -> Bool
- writable, -- :: Permissions -> Bool
- executable, -- :: Permissions -> Bool
- searchable -- :: Permissions -> Bool
- )
-
- , getPermissions -- :: FilePath -> IO Permissions
- , setPermissions -- :: FilePath -> Permissions -> IO ()
-
- -- * Timestamps
-
- , getModificationTime -- :: FilePath -> IO ClockTime
- ) where
-
-import System.Directory.Internals
-import System.Environment ( getEnv )
-import System.IO.Error
-import Control.Monad ( when, unless )
-
-#ifdef __NHC__
-import Directory
-#endif /* __NHC__ */
-
-#ifdef __HUGS__
-import Hugs.Directory
-#endif /* __HUGS__ */
-
-import Foreign
-import Foreign.C
-
-{-# CFILES cbits/PrelIOUtils.c #-}
-
-#ifdef __GLASGOW_HASKELL__
-import Prelude
-
-import Control.Exception ( bracket )
-import System.Posix.Types
-import System.Posix.Internals
-import System.Time ( ClockTime(..) )
-import System.IO
-
-import GHC.IOBase ( IOException(..), IOErrorType(..), ioException )
-
-{- $intro
-A directory contains a series of entries, each of which is a named
-reference to a file system object (file, directory etc.). Some
-entries may be hidden, inaccessible, or have some administrative
-function (e.g. `.' or `..' under POSIX
-<http://www.opengroup.org/onlinepubs/007904975/toc.htm>), but in
-this standard all such entries are considered to form part of the
-directory contents. Entries in sub-directories are not, however,
-considered to form part of the directory contents.
-
-Each file system object is referenced by a /path/. There is
-normally at least one absolute path to each file system object. In
-some operating systems, it may also be possible to have paths which
-are relative to the current directory.
--}
-
------------------------------------------------------------------------------
--- Permissions
-
-{- $permissions
-
- The 'Permissions' type is used to record whether certain operations are
- permissible on a file\/directory. 'getPermissions' and 'setPermissions'
- get and set these permissions, respectively. Permissions apply both to
- files and directories. For directories, the executable field will be
- 'False', and for files the searchable field will be 'False'. Note that
- directories may be searchable without being readable, if permission has
- been given to use them as part of a path, but not to examine the
- directory contents.
-
-Note that to change some, but not all permissions, a construct on the following lines must be used.
-
-> makeReadable f = do
-> p <- getPermissions f
-> setPermissions f (p {readable = True})
-
--}
-
-data Permissions
- = Permissions {
- readable, writable,
- executable, searchable :: Bool
- } deriving (Eq, Ord, Read, Show)
-
-{- |The 'getPermissions' operation returns the
-permissions for the file or directory.
-
-The operation may fail with:
-
-* 'isPermissionError' if the user is not permitted to access
- the permissions; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
-
--}
-
-getPermissions :: FilePath -> IO Permissions
-getPermissions name = do
- withCString name $ \s -> do
- read <- c_access s r_OK
- write <- c_access s w_OK
- exec <- c_access s x_OK
- withFileStatus "getPermissions" name $ \st -> do
- is_dir <- isDirectory st
- return (
- Permissions {
- readable = read == 0,
- writable = write == 0,
- executable = not is_dir && exec == 0,
- searchable = is_dir && exec == 0
- }
- )
-
-{- |The 'setPermissions' operation sets the
-permissions for the file or directory.
-
-The operation may fail with:
-
-* 'isPermissionError' if the user is not permitted to set
- the permissions; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
-
--}
-
-setPermissions :: FilePath -> Permissions -> IO ()
-setPermissions name (Permissions r w e s) = do
- allocaBytes sizeof_stat $ \ p_stat -> do
- withCString name $ \p_name -> do
- throwErrnoIfMinus1_ "setPermissions" $ do
- c_stat p_name p_stat
- mode <- st_mode p_stat
- let mode1 = modifyBit r mode s_IRUSR
- let mode2 = modifyBit w mode1 s_IWUSR
- let mode3 = modifyBit (e || s) mode2 s_IXUSR
- c_chmod p_name mode3
-
- where
- modifyBit :: Bool -> CMode -> CMode -> CMode
- modifyBit False m b = m .&. (complement b)
- modifyBit True m b = m .|. b
-
-
-copyPermissions :: FilePath -> FilePath -> IO ()
-copyPermissions source dest = do
- allocaBytes sizeof_stat $ \ p_stat -> do
- withCString source $ \p_source -> do
- withCString dest $ \p_dest -> do
- throwErrnoIfMinus1_ "copyPermissions" $ c_stat p_source p_stat
- mode <- st_mode p_stat
- throwErrnoIfMinus1_ "copyPermissions" $ c_chmod p_dest mode
-
------------------------------------------------------------------------------
--- Implementation
-
-{- |@'createDirectory' dir@ creates a new directory @dir@ which is
-initially empty, or as near to empty as the operating system
-allows.
-
-The operation may fail with:
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EROFS, EACCES]@
-
-* 'isAlreadyExistsError' \/ 'AlreadyExists'
-The operand refers to a directory that already exists.
-@ [EEXIST]@
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-The operand is not a valid directory name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'NoSuchThing'
-There is no path to the directory.
-@[ENOENT, ENOTDIR]@
-
-* 'ResourceExhausted'
-Insufficient resources (virtual memory, process file descriptors,
-physical disk space, etc.) are available to perform the operation.
-@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
-
-* 'InappropriateType'
-The path refers to an existing non-directory object.
-@[EEXIST]@
-
--}
-
-createDirectory :: FilePath -> IO ()
-createDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s -> do
- throwErrnoIfMinus1Retry_ "createDirectory" $
- mkdir s 0o777
-
-#else /* !__GLASGOW_HASKELL__ */
-
-copyPermissions :: FilePath -> FilePath -> IO ()
-copyPermissions fromFPath toFPath
- = getPermissions fromFPath >>= setPermissions toFPath
-
-#endif
-
--- | @'createDirectoryIfMissing' parents dir@ creates a new directory
--- @dir@ if it doesn\'t exist. If the first argument is 'True'
--- the function will also create all parent directories if they are missing.
-createDirectoryIfMissing :: Bool -- ^ Create its parents too?
- -> FilePath -- ^ The path to the directory you want to make
- -> IO ()
-createDirectoryIfMissing parents file = do
- b <- doesDirectoryExist file
- case (b,parents, file) of
- (_, _, "") -> return ()
- (True, _, _) -> return ()
- (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
- (_, False, _) -> createDirectory file
-
-#if __GLASGOW_HASKELL__
-{- | @'removeDirectory' dir@ removes an existing directory /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
-for an implementation to partially remove a directory unless the
-entire directory is removed. A conformant implementation need not
-support directory removal in all situations (e.g. removal of the root
-directory).
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-EIO
-
-* 'InvalidArgument'
-The operand is not a valid directory name.
-[ENAMETOOLONG, ELOOP]
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The directory does not exist.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EROFS, EACCES, EPERM]@
-
-* 'UnsatisfiedConstraints'
-Implementation-dependent constraints are not satisfied.
-@[EBUSY, ENOTEMPTY, EEXIST]@
-
-* 'UnsupportedOperation'
-The implementation does not support removal in this situation.
-@[EINVAL]@
-
-* 'InappropriateType'
-The operand refers to an existing non-directory object.
-@[ENOTDIR]@
-
--}
-
-removeDirectory :: FilePath -> IO ()
-removeDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s)
-#endif
-
--- | @'removeDirectoryRecursive' dir@ removes an existing directory /dir/
--- together with its content and all subdirectories. Be careful,
--- if the directory contains symlinks, the function will follow them.
-removeDirectoryRecursive :: FilePath -> IO ()
-removeDirectoryRecursive startLoc = do
- cont <- getDirectoryContents startLoc
- sequence_ [rm (startLoc `joinFileName` x) | x <- cont, x /= "." && x /= ".."]
- removeDirectory startLoc
- where
- rm :: FilePath -> IO ()
- rm f = do temp <- try (removeFile f)
- case temp of
- Left e -> do isDir <- doesDirectoryExist f
- -- If f is not a directory, re-throw the error
- unless isDir $ ioError e
- removeDirectoryRecursive f
- Right _ -> return ()
-
-#if __GLASGOW_HASKELL__
-{- |'removeFile' /file/ removes the directory entry for an existing file
-/file/, where /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
-use by other processes).
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-The operand is not a valid file name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The file does not exist.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EROFS, EACCES, EPERM]@
-
-* 'UnsatisfiedConstraints'
-Implementation-dependent constraints are not satisfied.
-@[EBUSY]@
-
-* 'InappropriateType'
-The operand refers to an existing directory.
-@[EPERM, EINVAL]@
-
--}
-
-removeFile :: FilePath -> IO ()
-removeFile path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "removeFile" (c_unlink s)
-
-{- |@'renameDirectory' old new@ changes the name of an existing
-directory from /old/ to /new/. If the /new/ directory
-already exists, it is atomically replaced by the /old/ directory.
-If the /new/ directory is neither the /old/ directory nor an
-alias of the /old/ directory, it is removed as if by
-'removeDirectory'. A conformant implementation need not support
-renaming directories in all situations (e.g. renaming to an existing
-directory, or across different physical devices), but the constraints
-must be documented.
-
-On Win32 platforms, @renameDirectory@ fails if the /new/ directory already
-exists.
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-Either operand is not a valid directory name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The original directory does not exist, or there is no path to the target.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EROFS, EACCES, EPERM]@
-
-* 'ResourceExhausted'
-Insufficient resources are available to perform the operation.
-@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
-
-* 'UnsatisfiedConstraints'
-Implementation-dependent constraints are not satisfied.
-@[EBUSY, ENOTEMPTY, EEXIST]@
-
-* 'UnsupportedOperation'
-The implementation does not support renaming in this situation.
-@[EINVAL, EXDEV]@
-
-* 'InappropriateType'
-Either path refers to an existing non-directory object.
-@[ENOTDIR, EISDIR]@
-
--}
-
-renameDirectory :: FilePath -> FilePath -> IO ()
-renameDirectory opath npath =
- withFileStatus "renameDirectory" opath $ \st -> do
- is_dir <- isDirectory st
- if (not is_dir)
- then ioException (IOError Nothing InappropriateType "renameDirectory"
- ("not a directory") (Just opath))
- else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2)
-
-{- |@'renameFile' old new@ changes the name of an existing file system
-object from /old/ to /new/. If the /new/ object already
-exists, it is atomically replaced by the /old/ object. Neither
-path may refer to an existing directory. A conformant implementation
-need not support renaming files in all situations (e.g. renaming
-across different physical devices), but the constraints must be
-documented.
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-Either operand is not a valid file name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The original file does not exist, or there is no path to the target.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EROFS, EACCES, EPERM]@
-
-* 'ResourceExhausted'
-Insufficient resources are available to perform the operation.
-@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@
-
-* 'UnsatisfiedConstraints'
-Implementation-dependent constraints are not satisfied.
-@[EBUSY]@
-
-* 'UnsupportedOperation'
-The implementation does not support renaming in this situation.
-@[EXDEV]@
-
-* 'InappropriateType'
-Either path refers to an existing directory.
-@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@
-
--}
-
-renameFile :: FilePath -> FilePath -> IO ()
-renameFile opath npath =
- withFileOrSymlinkStatus "renameFile" opath $ \st -> do
- is_dir <- isDirectory st
- if is_dir
- then ioException (IOError Nothing InappropriateType "renameFile"
- "is a directory" (Just opath))
- else do
-
- withCString opath $ \s1 ->
- withCString npath $ \s2 ->
- throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
-
-#endif /* __GLASGOW_HASKELL__ */
-
-{- |@'copyFile' old new@ copies the existing file from /old/ to /new/.
-If the /new/ file already exists, it is atomically replaced by the /old/ file.
-Neither path may refer to an existing directory. The permissions of /old/ are
-copied to /new/, if possible.
--}
-
-{- NOTES:
-
-It's tempting to try to remove the target file before opening it for
-writing. This could be useful: for example if the target file is an
-executable that is in use, writing will fail, but unlinking first
-would succeed.
-
-However, it certainly isn't always what you want.
-
- * if the target file is hardlinked, removing it would break
- the hard link, but just opening would preserve it.
-
- * opening and truncating will preserve permissions and
- ACLs on the target.
-
- * If the destination file is read-only in a writable directory,
- we might want copyFile to fail. Removing the target first
- would succeed, however.
-
- * If the destination file is special (eg. /dev/null), removing
- it is probably not the right thing. Copying to /dev/null
- should leave /dev/null intact, not replace it with a plain
- file.
-
- * There's a small race condition between removing the target and
- opening it for writing during which time someone might
- create it again.
--}
-copyFile :: FilePath -> FilePath -> IO ()
-copyFile fromFPath toFPath =
-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
- do readFile fromFPath >>= writeFile toFPath
- try (copyPermissions fromFPath toFPath)
- return ()
-#else
- (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer -> do
- copyContents hFrom hTo buffer
- try (copyPermissions fromFPath toFPath)
- return ()) `catch` (ioError . changeFunName)
- where
- bufferSize = 1024
-
- changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
-
- copyContents hFrom hTo buffer = do
- count <- hGetBuf hFrom buffer bufferSize
- when (count > 0) $ do
- hPutBuf hTo buffer count
- copyContents hFrom hTo buffer
-#endif
-
--- | Given path referring to a file or directory, returns a
--- canonicalized path, with the intent that two paths referring
--- to the same file\/directory will map to the same canonicalized
--- path. Note that it is impossible to guarantee that the
--- implication (same file\/dir \<=\> same canonicalizedPath) holds
--- in either direction: this function can make only a best-effort
--- attempt.
-canonicalizePath :: FilePath -> IO FilePath
-canonicalizePath fpath =
- withCString fpath $ \pInPath ->
- allocaBytes long_path_size $ \pOutPath ->
-#if defined(mingw32_HOST_OS)
- alloca $ \ppFilePart ->
- do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
-#else
- do c_realpath pInPath pOutPath
-#endif
- peekCString pOutPath
-
-#if defined(mingw32_HOST_OS)
-foreign import stdcall unsafe "GetFullPathNameA"
- c_GetFullPathName :: CString
- -> CInt
- -> CString
- -> Ptr CString
- -> IO CInt
-#else
-foreign import ccall unsafe "realpath"
- c_realpath :: CString
- -> CString
- -> IO CString
-#endif
-
--- | Given an executable file name, searches for such file
--- in the directories listed in system PATH. The returned value
--- is the path to the found executable or Nothing if there isn't
--- such executable. For example (findExecutable \"ghc\")
--- gives you the path to GHC.
-findExecutable :: String -> IO (Maybe FilePath)
-findExecutable binary =
-#if defined(mingw32_HOST_OS)
- withCString binary $ \c_binary ->
- withCString ('.':exeExtension) $ \c_ext ->
- allocaBytes long_path_size $ \pOutPath ->
- alloca $ \ppFilePart -> do
- res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
- if res > 0 && res < fromIntegral long_path_size
- then do fpath <- peekCString pOutPath
- return (Just fpath)
- else return Nothing
-
-foreign import stdcall unsafe "SearchPathA"
- c_SearchPath :: CString
- -> CString
- -> CString
- -> CInt
- -> CString
- -> Ptr CString
- -> IO CInt
-#else
- do
- path <- getEnv "PATH"
- search (parseSearchPath path)
- where
- fileName = binary `joinFileExt` exeExtension
-
- search :: [FilePath] -> IO (Maybe FilePath)
- search [] = return Nothing
- search (d:ds) = do
- let path = d `joinFileName` fileName
- b <- doesFileExist path
- if b then return (Just path)
- else search ds
-#endif
-
-
-#ifdef __GLASGOW_HASKELL__
-{- |@'getDirectoryContents' dir@ returns a list of /all/ entries
-in /dir/.
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-The operand is not a valid directory name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The directory does not exist.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EACCES]@
-
-* 'ResourceExhausted'
-Insufficient resources are available to perform the operation.
-@[EMFILE, ENFILE]@
-
-* 'InappropriateType'
-The path refers to an existing non-directory object.
-@[ENOTDIR]@
-
--}
-
-getDirectoryContents :: FilePath -> IO [FilePath]
-getDirectoryContents path = do
- modifyIOError (`ioeSetFileName` path) $
- alloca $ \ ptr_dEnt ->
- bracket
- (withCString path $ \s ->
- throwErrnoIfNullRetry desc (c_opendir s))
- (\p -> throwErrnoIfMinus1_ desc (c_closedir p))
- (\p -> loop ptr_dEnt p)
- where
- desc = "getDirectoryContents"
-
- loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String]
- loop ptr_dEnt dir = do
- resetErrno
- r <- readdir dir ptr_dEnt
- if (r == 0)
- then do
- dEnt <- peek ptr_dEnt
- if (dEnt == nullPtr)
- then return []
- else do
- entry <- (d_name dEnt >>= peekCString)
- freeDirEnt dEnt
- entries <- loop ptr_dEnt dir
- return (entry:entries)
- else do errno <- getErrno
- if (errno == eINTR) then loop ptr_dEnt dir else do
- let (Errno eo) = errno
- if (eo == end_of_dir)
- then return []
- else throwErrno desc
-
-
-
-{- |If the operating system has a notion of current directories,
-'getCurrentDirectory' returns an absolute path to the
-current directory of the calling process.
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-There is no path referring to the current directory.
-@[EPERM, ENOENT, ESTALE...]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EACCES]@
-
-* 'ResourceExhausted'
-Insufficient resources are available to perform the operation.
-
-* 'UnsupportedOperation'
-The operating system has no notion of current directory.
-
--}
-
-getCurrentDirectory :: IO FilePath
-getCurrentDirectory = do
- p <- mallocBytes long_path_size
- go p long_path_size
- where go p bytes = do
- p' <- c_getcwd p (fromIntegral bytes)
- if p' /= nullPtr
- then do s <- peekCString p'
- free p'
- return s
- else do errno <- getErrno
- if errno == eRANGE
- then do let bytes' = bytes * 2
- p' <- reallocBytes p bytes'
- go p' bytes'
- else throwErrno "getCurrentDirectory"
-
-{- |If the operating system has a notion of current directories,
-@'setCurrentDirectory' dir@ changes the current
-directory of the calling process to /dir/.
-
-The operation may fail with:
-
-* 'HardwareFault'
-A physical I\/O error has occurred.
-@[EIO]@
-
-* 'InvalidArgument'
-The operand is not a valid directory name.
-@[ENAMETOOLONG, ELOOP]@
-
-* 'isDoesNotExistError' \/ 'NoSuchThing'
-The directory does not exist.
-@[ENOENT, ENOTDIR]@
-
-* 'isPermissionError' \/ 'PermissionDenied'
-The process has insufficient privileges to perform the operation.
-@[EACCES]@
-
-* 'UnsupportedOperation'
-The operating system has no notion of current directory, or the
-current directory cannot be dynamically changed.
-
-* 'InappropriateType'
-The path refers to an existing non-directory object.
-@[ENOTDIR]@
-
--}
-
-setCurrentDirectory :: FilePath -> IO ()
-setCurrentDirectory path = do
- modifyIOError (`ioeSetFileName` path) $
- withCString path $ \s ->
- throwErrnoIfMinus1Retry_ "setCurrentDirectory" (c_chdir s)
- -- ToDo: add path to error
-
-{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
-exists and is a directory, and 'False' otherwise.
--}
-
-doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name =
- catch
- (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
- (\ _ -> return False)
-
-{- |The operation 'doesFileExist' returns 'True'
-if the argument file exists and is not a directory, and 'False' otherwise.
--}
-
-doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do
- catch
- (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
- (\ _ -> return False)
-
-{- |The 'getModificationTime' operation returns the
-clock time at which the file or directory was last modified.
-
-The operation may fail with:
-
-* 'isPermissionError' if the user is not permitted to access
- the modification time; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
-
--}
-
-getModificationTime :: FilePath -> IO ClockTime
-getModificationTime name =
- withFileStatus "getModificationTime" name $ \ st ->
- modificationTime st
-
-withFileStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileStatus loc name f = do
- modifyIOError (`ioeSetFileName` name) $
- allocaBytes sizeof_stat $ \p ->
- withCString (fileNameEndClean name) $ \s -> do
- throwErrnoIfMinus1Retry_ loc (c_stat s p)
- f p
-
-withFileOrSymlinkStatus :: String -> FilePath -> (Ptr CStat -> IO a) -> IO a
-withFileOrSymlinkStatus loc name f = do
- modifyIOError (`ioeSetFileName` name) $
- allocaBytes sizeof_stat $ \p ->
- withCString name $ \s -> do
- throwErrnoIfMinus1Retry_ loc (lstat s p)
- f p
-
-modificationTime :: Ptr CStat -> IO ClockTime
-modificationTime stat = do
- mtime <- st_mtime stat
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (TOD (realToInteger (mtime :: CTime)) 0)
-
-isDirectory :: Ptr CStat -> IO Bool
-isDirectory stat = do
- mode <- st_mode stat
- return (s_isdir mode)
-
-fileNameEndClean :: String -> String
-fileNameEndClean name =
- if i > 0 && (ec == '\\' || ec == '/') then
- fileNameEndClean (take i name)
- else
- name
- where
- i = (length name) - 1
- ec = name !! i
-
-foreign import ccall unsafe "__hscore_R_OK" r_OK :: CInt
-foreign import ccall unsafe "__hscore_W_OK" w_OK :: CInt
-foreign import ccall unsafe "__hscore_X_OK" x_OK :: CInt
-
-foreign import ccall unsafe "__hscore_S_IRUSR" s_IRUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IWUSR" s_IWUSR :: CMode
-foreign import ccall unsafe "__hscore_S_IXUSR" s_IXUSR :: CMode
-
-foreign import ccall unsafe "__hscore_long_path_size"
- long_path_size :: Int
-
-#else
-long_path_size :: Int
-long_path_size = 2048 /* guess? */
-
-#endif /* __GLASGOW_HASKELL__ */
-
-{- | Returns the current user's home directory.
-
-The directory returned is expected to be writable by the current user,
-but note that it isn't generally considered good practice to store
-application-specific data here; use 'getAppUserDataDirectory'
-instead.
-
-On Unix, 'getHomeDirectory' returns the value of the @HOME@
-environment variable. On Windows, the system is queried for a
-suitable path; a typical path might be
-@C:/Documents And Settings/user@.
-
-The operation may fail with:
-
-* 'UnsupportedOperation'
-The operating system has no notion of home directory.
-
-* 'isDoesNotExistError'
-The home directory for the current user does not exist, or
-cannot be found.
--}
-getHomeDirectory :: IO FilePath
-getHomeDirectory =
-#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_PROFILE nullPtr 0 pPath
- if (r < 0)
- then do
- r <- c_SHGetFolderPath nullPtr csidl_WINDOWS nullPtr 0 pPath
- when (r < 0) (raiseUnsupported "System.Directory.getHomeDirectory")
- else return ()
- peekCString pPath
-#else
- getEnv "HOME"
-#endif
-
-{- | Returns the pathname of a directory in which application-specific
-data for the current user can be stored. The result of
-'getAppUserDataDirectory' for a given application is specific to
-the current user.
-
-The argument should be the name of the application, which will be used
-to construct the pathname (so avoid using unusual characters that
-might result in an invalid pathname).
-
-Note: the directory may not actually exist, and may need to be created
-first. It is expected that the parent directory exists and is
-writable.
-
-On Unix, this function returns @$HOME\/.appName@. On Windows, a
-typical path might be
-
-> C:/Documents And Settings/user/Application Data/appName
-
-The operation may fail with:
-
-* 'UnsupportedOperation'
-The operating system has no notion of application-specific data directory.
-
-* 'isDoesNotExistError'
-The home directory for the current user does not exist, or
-cannot be found.
--}
-getAppUserDataDirectory :: String -> IO FilePath
-getAppUserDataDirectory appName = do
-#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
- when (r<0) (raiseUnsupported "System.Directory.getAppUserDataDirectory")
- s <- peekCString pPath
- return (s++'\\':appName)
-#else
- path <- getEnv "HOME"
- return (path++'/':'.':appName)
-#endif
-
-{- | Returns the current user's document directory.
-
-The directory returned is expected to be writable by the current user,
-but note that it isn't generally considered good practice to store
-application-specific data here; use 'getAppUserDataDirectory'
-instead.
-
-On Unix, 'getUserDocumentsDirectory' returns the value of the @HOME@
-environment variable. On Windows, the system is queried for a
-suitable path; a typical path might be
-@C:\/Documents and Settings\/user\/My Documents@.
-
-The operation may fail with:
-
-* 'UnsupportedOperation'
-The operating system has no notion of document directory.
-
-* 'isDoesNotExistError'
-The document directory for the current user does not exist, or
-cannot be found.
--}
-getUserDocumentsDirectory :: IO FilePath
-getUserDocumentsDirectory = do
-#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_PERSONAL nullPtr 0 pPath
- when (r<0) (raiseUnsupported "System.Directory.getUserDocumentsDirectory")
- peekCString pPath
-#else
- getEnv "HOME"
-#endif
-
-{- | Returns the current directory for temporary files.
-
-On Unix, 'getTemporaryDirectory' returns the value of the @TMPDIR@
-environment variable or \"\/tmp\" if the variable isn\'t defined.
-On Windows, the function checks for the existence of environment variables in
-the following order and uses the first path found:
-
-*
-TMP environment variable.
-
-*
-TEMP environment variable.
-
-*
-USERPROFILE environment variable.
-
-*
-The Windows directory
-
-The operation may fail with:
-
-* 'UnsupportedOperation'
-The operating system has no notion of temporary directory.
-
-The function doesn\'t verify whether the path exists.
--}
-getTemporaryDirectory :: IO FilePath
-getTemporaryDirectory = do
-#if defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_GetTempPath (fromIntegral long_path_size) pPath
- peekCString pPath
-#else
- catch (getEnv "TMPDIR") (\ex -> return "/tmp")
-#endif
-
-#if defined(mingw32_HOST_OS)
-foreign import ccall unsafe "__hscore_getFolderPath"
- c_SHGetFolderPath :: Ptr ()
- -> CInt
- -> Ptr ()
- -> CInt
- -> CString
- -> IO CInt
-foreign import ccall unsafe "__hscore_CSIDL_PROFILE" csidl_PROFILE :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_WINDOWS" csidl_WINDOWS :: CInt
-foreign import ccall unsafe "__hscore_CSIDL_PERSONAL" csidl_PERSONAL :: CInt
-
-foreign import stdcall unsafe "GetTempPathA" c_GetTempPath :: CInt -> CString -> IO CInt
-
-raiseUnsupported loc =
- ioException (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
-
-#endif
+++ /dev/null
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
------------------------------------------------------------------------------
--- |
--- Module : System.Directory.Internals
--- Copyright : (c) The University of Glasgow 2005
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : hidden
--- Portability : portable
---
--- System-independent pathname manipulations.
---
------------------------------------------------------------------------------
-
--- #hide
-module System.Directory.Internals (
- joinFileName,
- joinFileExt,
- parseSearchPath,
- pathParents,
- exeExtension,
- ) where
-
-#if __GLASGOW_HASKELL__
-import GHC.Base
-import GHC.IOBase (FilePath)
-#endif
-import Data.List
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | The 'joinFileExt' function is the opposite of 'splitFileExt'.
--- It joins a file name and an extension to form a complete file path.
---
--- The general rule is:
---
--- > filename `joinFileExt` ext == path
--- > where
--- > (filename,ext) = splitFileExt path
-joinFileExt :: String -> String -> FilePath
-joinFileExt path "" = path
-joinFileExt path ext = path ++ '.':ext
-
--- | Gets this path and all its parents.
--- The function is useful in case if you want to create
--- some file but you aren\'t sure whether all directories
--- in the path exist or if you want to search upward for some file.
---
--- Some examples:
---
--- \[Posix\]
---
--- > pathParents "/" == ["/"]
--- > pathParents "/dir1" == ["/", "/dir1"]
--- > pathParents "/dir1/dir2" == ["/", "/dir1", "/dir1/dir2"]
--- > pathParents "dir1" == [".", "dir1"]
--- > pathParents "dir1/dir2" == [".", "dir1", "dir1/dir2"]
---
--- \[Windows\]
---
--- > pathParents "c:" == ["c:."]
--- > pathParents "c:\\" == ["c:\\"]
--- > pathParents "c:\\dir1" == ["c:\\", "c:\\dir1"]
--- > pathParents "c:\\dir1\\dir2" == ["c:\\", "c:\\dir1", "c:\\dir1\\dir2"]
--- > pathParents "c:dir1" == ["c:.","c:dir1"]
--- > pathParents "dir1\\dir2" == [".", "dir1", "dir1\\dir2"]
---
--- Note that if the file is relative then the current directory (\".\")
--- will be explicitly listed.
-pathParents :: FilePath -> [FilePath]
-pathParents p =
- root'' : map ((++) root') (dropEmptyPath $ inits path')
- where
-#ifdef mingw32_HOST_OS
- (root,path) = case break (== ':') p of
- (path, "") -> ("",path)
- (root,_:path) -> (root++":",path)
-#else
- (root,path) = ("",p)
-#endif
- (root',root'',path') = case path of
- (c:path) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path)
- _ -> (root ,root++"." ,path)
-
- dropEmptyPath ("":paths) = paths
- dropEmptyPath paths = paths
-
- inits :: String -> [String]
- inits [] = [""]
- inits cs =
- case pre of
- "." -> inits suf
- ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf)
- _ -> "" : map (joinFileName pre) (inits suf)
- where
- (pre,suf) = case break isPathSeparator cs of
- (pre,"") -> (pre, "")
- (pre,_:suf) -> (pre,suf)
-
---------------------------------------------------------------
--- * Search path
---------------------------------------------------------------
-
--- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split path
- where
- split :: String -> [String]
- split s =
- case rest' of
- [] -> [chunk]
- _:rest -> chunk : split rest
- where
- chunk =
- case chunk' of
-#ifdef mingw32_HOST_OS
- ('\"':xs@(_:_)) | last xs == '\"' -> init xs
-#endif
- _ -> chunk'
-
- (chunk', rest') = break (==searchPathSeparator) s
-
---------------------------------------------------------------
--- * Separators
---------------------------------------------------------------
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch = ch == pathSeparator || ch == '/'
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- ToDo: This should be determined via autoconf (PATH_SEPARATOR)
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (@\":\"@) on Unix and
--- Macintosh, and a semicolon (@\";\"@) on the Windows operating system.
-searchPathSeparator :: Char
-#ifdef mingw32_HOST_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-
--- ToDo: This should be determined via autoconf (AC_EXEEXT)
--- | Extension for executable files
--- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
-exeExtension :: String
-#ifdef mingw32_HOST_OS
-exeExtension = "exe"
-#else
-exeExtension = ""
-#endif
-
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Random
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : stable
--- Portability : portable
---
--- This library deals with the common task of pseudo-random number
--- generation. The library makes it possible to generate repeatable
--- results, by starting with a specified initial random number generator,
--- or to get different results on each run by using the system-initialised
--- generator or by supplying a seed from some other source.
---
--- The library is split into two layers:
---
--- * A core /random number generator/ provides a supply of bits.
--- The class 'RandomGen' provides a common interface to such generators.
--- The library provides one instance of 'RandomGen', the abstract
--- data type 'StdGen'. Programmers may, of course, supply their own
--- instances of 'RandomGen'.
---
--- * The class 'Random' provides a way to extract values of a particular
--- type from a random number generator. For example, the 'Float'
--- instance of 'Random' allows one to generate random values of type
--- 'Float'.
---
--- This implementation uses the Portable Combined Generator of L'Ecuyer
--- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by
--- Lennart Augustsson. It has a period of roughly 2.30584e18.
---
------------------------------------------------------------------------------
-
-module System.Random
- (
-
- -- $intro
-
- -- * Random number generators
-
- RandomGen(next, split, genRange)
-
- -- ** Standard random number generators
- , StdGen
- , mkStdGen
-
- -- ** The global random number generator
-
- -- $globalrng
-
- , getStdRandom
- , getStdGen
- , setStdGen
- , newStdGen
-
- -- * Random values of various types
- , Random ( random, randomR,
- randoms, randomRs,
- randomIO, randomRIO )
-
- -- * References
- -- $references
-
- ) where
-
-import Prelude
-
-#ifdef __NHC__
-import CPUTime ( getCPUTime )
-import Foreign.Ptr ( Ptr, nullPtr )
-import Foreign.C ( CTime, CUInt )
-#else
-import System.CPUTime ( getCPUTime )
-import System.Time ( getClockTime, ClockTime(..) )
-#endif
-import Data.Char ( isSpace, chr, ord )
-import System.IO.Unsafe ( unsafePerformIO )
-import Data.IORef
-import Numeric ( readDec )
-
--- The standard nhc98 implementation of Time.ClockTime does not match
--- the extended one expected in this module, so we lash-up a quick
--- replacement here.
-#ifdef __NHC__
-data ClockTime = TOD Integer ()
-foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime
-getClockTime :: IO ClockTime
-getClockTime = do CTime t <- readtime nullPtr; return (TOD (toInteger t) ())
-#endif
-
--- | The class 'RandomGen' provides a common interface to random number
--- generators.
---
--- Minimal complete definition: 'next' and 'split'.
-
-class RandomGen g where
-
- -- |The 'next' operation returns an 'Int' that is uniformly distributed
- -- in the range returned by 'genRange' (including both end points),
- -- and a new generator.
- next :: g -> (Int, g)
-
- -- |The 'split' operation allows one to obtain two distinct random number
- -- generators. This is very useful in functional programs (for example, when
- -- passing a random number generator down to recursive calls), but very
- -- little work has been done on statistically robust implementations of
- -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"]
- -- are the only examples we know of).
- split :: g -> (g, g)
-
- -- |The 'genRange' operation yields the range of values returned by
- -- the generator.
- --
- -- It is required that:
- --
- -- * If @(a,b) = 'genRange' g@, then @a < b@.
- --
- -- * 'genRange' always returns a pair of defined 'Int's.
- --
- -- The second condition ensures that 'genRange' cannot examine its
- -- argument, and hence the value it returns can be determined only by the
- -- instance of 'RandomGen'. That in turn allows an implementation to make
- -- a single call to 'genRange' to establish a generator's range, without
- -- being concerned that the generator returned by (say) 'next' might have
- -- a different range to the generator passed to 'next'.
- --
- -- The default definition spans the full range of 'Int'.
- genRange :: g -> (Int,Int)
-
- -- default method
- genRange g = (minBound,maxBound)
-
-{- |
-The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits.
-
-The result of repeatedly using 'next' should be at least as statistically
-robust as the /Minimal Standard Random Number Generator/ described by
-["System.Random\#Park", "System.Random\#Carta"].
-Until more is known about implementations of 'split', all we require is
-that 'split' deliver generators that are (a) not identical and
-(b) independently robust in the sense just given.
-
-The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the
-state of a random number generator.
-It is required that @'read' ('show' g) == g@.
-
-In addition, 'read' may be used to map an arbitrary string (not necessarily one
-produced by 'show') onto a value of type 'StdGen'. In general, the 'read'
-instance of 'StdGen' has the following properties:
-
-* It guarantees to succeed on any string.
-
-* It guarantees to consume only a finite portion of the string.
-
-* Different argument strings are likely to result in different results.
-
--}
-
-data StdGen
- = StdGen Int Int
-
-instance RandomGen StdGen where
- next = stdNext
- split = stdSplit
- genRange _ = stdRange
-
-instance Show StdGen where
- showsPrec p (StdGen s1 s2) =
- showsPrec p s1 .
- showChar ' ' .
- showsPrec p s2
-
-instance Read StdGen where
- readsPrec _p = \ r ->
- case try_read r of
- r@[_] -> r
- _ -> [stdFromString r] -- because it shouldn't ever fail.
- where
- try_read r = do
- (s1, r1) <- readDec (dropWhile isSpace r)
- (s2, r2) <- readDec (dropWhile isSpace r1)
- return (StdGen s1 s2, r2)
-
-{-
- If we cannot unravel the StdGen from a string, create
- one based on the string given.
--}
-stdFromString :: String -> (StdGen, String)
-stdFromString s = (mkStdGen num, rest)
- where (cs, rest) = splitAt 6 s
- num = foldl (\a x -> x + 3 * a) 1 (map ord cs)
-
-
-{- |
-The function 'mkStdGen' provides an alternative way of producing an initial
-generator, by mapping an 'Int' into a generator. Again, distinct arguments
-should be likely to produce distinct generators.
--}
-mkStdGen :: Int -> StdGen -- why not Integer ?
-mkStdGen s
- | s < 0 = mkStdGen (-s)
- | otherwise = StdGen (s1+1) (s2+1)
- where
- (q, s1) = s `divMod` 2147483562
- s2 = q `mod` 2147483398
-
-createStdGen :: Integer -> StdGen
-createStdGen s
- | s < 0 = createStdGen (-s)
- | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1))
- where
- (q, s1) = s `divMod` 2147483562
- s2 = q `mod` 2147483398
-
--- FIXME: 1/2/3 below should be ** (vs@30082002) XXX
-
-{- |
-With a source of random number supply in hand, the 'Random' class allows the
-programmer to extract random values of a variety of types.
-
-Minimal complete definition: 'randomR' and 'random'.
-
--}
-
-class Random a where
- -- | Takes a range /(lo,hi)/ and a random number generator
- -- /g/, and returns a random value uniformly distributed in the closed
- -- interval /[lo,hi]/, together with a new generator. It is unspecified
- -- what happens if /lo>hi/. For continuous types there is no requirement
- -- that the values /lo/ and /hi/ are ever produced, but they may be,
- -- depending on the implementation and the interval.
- randomR :: RandomGen g => (a,a) -> g -> (a,g)
-
- -- | The same as 'randomR', but using a default range determined by the type:
- --
- -- * For bounded types (instances of 'Bounded', such as 'Char'),
- -- the range is normally the whole type.
- --
- -- * For fractional types, the range is normally the semi-closed interval
- -- @[0,1)@.
- --
- -- * For 'Integer', the range is (arbitrarily) the range of 'Int'.
- random :: RandomGen g => g -> (a, g)
-
- -- | Plural variant of 'randomR', producing an infinite list of
- -- random values instead of returning a new generator.
- randomRs :: RandomGen g => (a,a) -> g -> [a]
- randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
-
- -- | Plural variant of 'random', producing an infinite list of
- -- random values instead of returning a new generator.
- randoms :: RandomGen g => g -> [a]
- randoms g = (\(x,g') -> x : randoms g') (random g)
-
- -- | A variant of 'randomR' that uses the global random number generator
- -- (see "System.Random#globalrng").
- randomRIO :: (a,a) -> IO a
- randomRIO range = getStdRandom (randomR range)
-
- -- | A variant of 'random' that uses the global random number generator
- -- (see "System.Random#globalrng").
- randomIO :: IO a
- randomIO = getStdRandom random
-
-
-instance Random Int where
- randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
- random g = randomR (minBound,maxBound) g
-
-instance Random Char where
- randomR (a,b) g =
- case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
- (x,g) -> (chr x, g)
- random g = randomR (minBound,maxBound) g
-
-instance Random Bool where
- randomR (a,b) g =
- case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
- (x, g) -> (int2Bool x, g)
- where
- bool2Int False = 0
- bool2Int True = 1
-
- int2Bool 0 = False
- int2Bool _ = True
-
- random g = randomR (minBound,maxBound) g
-
-instance Random Integer where
- randomR ival g = randomIvalInteger ival g
- random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
-
-instance Random Double where
- randomR ival g = randomIvalDouble ival id g
- random g = randomR (0::Double,1) g
-
--- hah, so you thought you were saving cycles by using Float?
-instance Random Float where
- random g = randomIvalDouble (0::Double,1) realToFrac g
- randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
-
-mkStdRNG :: Integer -> IO StdGen
-mkStdRNG o = do
- ct <- getCPUTime
- (TOD sec _) <- getClockTime
- return (createStdGen (sec * 12345 + ct + o))
-
-randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
-randomIvalInteger (l,h) rng
- | l > h = randomIvalInteger (h,l) rng
- | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
- where
- k = h - l + 1
- b = 2147483561
- n = iLogBase b k
-
- f 0 acc g = (acc, g)
- f n acc g =
- let
- (x,g') = next g
- in
- f (n-1) (fromIntegral x + acc * b) g'
-
-randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
-randomIvalDouble (l,h) fromDouble rng
- | l > h = randomIvalDouble (h,l) fromDouble rng
- | otherwise =
- case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
- (x, rng') ->
- let
- scaled_x =
- fromDouble ((l+h)/2) +
- fromDouble ((h-l) / realToFrac intRange) *
- fromIntegral (x::Int)
- in
- (scaled_x, rng')
-
-intRange :: Integer
-intRange = toInteger (maxBound::Int) - toInteger (minBound::Int)
-
-iLogBase :: Integer -> Integer -> Integer
-iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
-
-stdRange :: (Int,Int)
-stdRange = (0, 2147483562)
-
-stdNext :: StdGen -> (Int, StdGen)
--- Returns values in the range stdRange
-stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
- where z' = if z < 1 then z + 2147483562 else z
- z = s1'' - s2''
-
- k = s1 `quot` 53668
- s1' = 40014 * (s1 - k * 53668) - k * 12211
- s1'' = if s1' < 0 then s1' + 2147483563 else s1'
-
- k' = s2 `quot` 52774
- s2' = 40692 * (s2 - k' * 52774) - k' * 3791
- s2'' = if s2' < 0 then s2' + 2147483399 else s2'
-
-stdSplit :: StdGen -> (StdGen, StdGen)
-stdSplit std@(StdGen s1 s2)
- = (left, right)
- where
- -- no statistical foundation for this!
- left = StdGen new_s1 t2
- right = StdGen t1 new_s2
-
- new_s1 | s1 == 2147483562 = 1
- | otherwise = s1 + 1
-
- new_s2 | s2 == 1 = 2147483398
- | otherwise = s2 - 1
-
- StdGen t1 t2 = snd (next std)
-
--- The global random number generator
-
-{- $globalrng #globalrng#
-
-There is a single, implicit, global random number generator of type
-'StdGen', held in some global variable maintained by the 'IO' monad. It is
-initialised automatically in some system-dependent fashion, for example, by
-using the time of day, or Linux's kernel random number generator. To get
-deterministic behaviour, use 'setStdGen'.
--}
-
--- |Sets the global random number generator.
-setStdGen :: StdGen -> IO ()
-setStdGen sgen = writeIORef theStdGen sgen
-
--- |Gets the global random number generator.
-getStdGen :: IO StdGen
-getStdGen = readIORef theStdGen
-
-theStdGen :: IORef StdGen
-theStdGen = unsafePerformIO $ do
- rng <- mkStdRNG 0
- newIORef rng
-
--- |Applies 'split' to the current global random generator,
--- updates it with one of the results, and returns the other.
-newStdGen :: IO StdGen
-newStdGen = do
- rng <- getStdGen
- let (a,b) = split rng
- setStdGen a
- return b
-
-{- |Uses the supplied function to get a value from the current global
-random generator, and updates the global generator with the new generator
-returned by the function. For example, @rollDice@ gets a random integer
-between 1 and 6:
-
-> rollDice :: IO Int
-> rollDice = getStdRandom (randomR (1,6))
-
--}
-
-getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
-getStdRandom f = do
- rng <- getStdGen
- let (v, new_rng) = f rng
- setStdGen new_rng
- return v
-
-{- $references
-
-1. FW #Burton# Burton and RL Page, /Distributed random number generation/,
-Journal of Functional Programming, 2(2):203-212, April 1992.
-
-2. SK #Park# Park, and KW Miller, /Random number generators -
-good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201.
-
-3. DG #Carta# Carta, /Two fast implementations of the minimal standard
-random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88.
-
-4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/,
-Department of Mathematics, University of Salzburg,
-<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998.
-
-5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random
-number generators/, Comm ACM, 31(6), Jun 1988, pp742-749.
-
-The Web site <http://random.mat.sbg.ac.at/> is a great source of information.
-
--}
+++ /dev/null
------------------------------------------------------------------------------
--- |
--- Module : System.Time
--- Copyright : (c) The University of Glasgow 2001
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- The standard Time library, providing standard functionality for clock
--- times, including timezone information (i.e, the functionality of
--- \"@time.h@\", adapted to the Haskell environment). It follows RFC
--- 1129 in its use of Coordinated Universal Time (UTC).
------------------------------------------------------------------------------
-
-{-
-Haskell 98 Time of Day Library
-------------------------------
-
-2000/06/17 <michael.weber@post.rwth-aachen.de>:
-RESTRICTIONS:
- * min./max. time diff currently is restricted to
- [minBound::Int, maxBound::Int]
-
- * surely other restrictions wrt. min/max bounds
-
-
-NOTES:
- * printing times
-
- `showTime' (used in `instance Show ClockTime') always prints time
- converted to the local timezone (even if it is taken from
- `(toClockTime . toUTCTime)'), whereas `calendarTimeToString'
- honors the tzone & tz fields and prints UTC or whatever timezone
- is stored inside CalendarTime.
-
- Maybe `showTime' should be changed to use UTC, since it would
- better correspond to the actual representation of `ClockTime'
- (can be done by replacing localtime(3) by gmtime(3)).
-
-
-BUGS:
- * add proper handling of microsecs, currently, they're mostly
- ignored
-
- * `formatFOO' case of `%s' is currently broken...
-
-
-TODO:
- * check for unusual date cases, like 1970/1/1 00:00h, and conversions
- between different timezone's etc.
-
- * check, what needs to be in the IO monad, the current situation
- seems to be a bit inconsistent to me
-
- * check whether `isDst = -1' works as expected on other arch's
- (Solaris anyone?)
-
- * add functions to parse strings to `CalendarTime' (some day...)
-
- * implement padding capabilities ("%_", "%-") in `formatFOO'
-
- * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO'
--}
-
-module System.Time
- (
- -- * Clock times
-
- ClockTime(..) -- non-standard, lib. report gives this as abstract
- -- instance Eq, Ord
- -- instance Show (non-standard)
-
- , getClockTime
-
- -- * Time differences
-
- , TimeDiff(..)
- , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.)
- , diffClockTimes
- , addToClockTime
-
- , normalizeTimeDiff -- non-standard
- , timeDiffToString -- non-standard
- , formatTimeDiff -- non-standard
-
- -- * Calendar times
-
- , CalendarTime(..)
- , Month(..)
- , Day(..)
- , toCalendarTime
- , toUTCTime
- , toClockTime
- , calendarTimeToString
- , formatCalendarTime
-
- ) where
-
-#ifdef __GLASGOW_HASKELL__
-#include "HsBase.h"
-#endif
-
-#ifdef __NHC__
-#include <time.h>
-# if defined(__sun) || defined(__CYGWIN32__)
-# define HAVE_TZNAME 1
-# else
-# define HAVE_TM_ZONE 1
-# endif
-import Ix
-#endif
-
-import Prelude
-
-import Data.Ix
-import System.Locale
-import System.IO.Unsafe
-
-#ifdef __HUGS__
-import Hugs.Time ( getClockTimePrim, toCalTimePrim, toClockTimePrim )
-#else
-import Foreign
-import Foreign.C
-#endif
-
--- One way to partition and give name to chunks of a year and a week:
-
--- | A month of the year.
-
-data Month
- = January | February | March | April
- | May | June | July | August
- | September | October | November | December
- deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
-
--- | A day of the week.
-
-data Day
- = Sunday | Monday | Tuesday | Wednesday
- | Thursday | Friday | Saturday
- deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
-
--- | A representation of the internal clock time.
--- Clock times may be compared, converted to strings, or converted to an
--- external calendar time 'CalendarTime' for I\/O or other manipulations.
-
-data ClockTime = TOD Integer Integer
- -- ^ Construct a clock time. The arguments are a number
- -- of seconds since 00:00:00 (UTC) on 1 January 1970,
- -- and an additional number of picoseconds.
- --
- -- In Haskell 98, the 'ClockTime' type is abstract.
- deriving (Eq, Ord)
-
--- When a ClockTime is shown, it is converted to a CalendarTime in the current
--- timezone and then printed. FIXME: This is arguably wrong, since we can't
--- get the current timezone without being in the IO monad.
-
-instance Show ClockTime where
- showsPrec _ t = showString (calendarTimeToString
- (unsafePerformIO (toCalendarTime t)))
-
-{-
-The numeric fields have the following ranges.
-
-\begin{verbatim}
-Value Range Comments
------ ----- --------
-
-year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate]
-day 1 .. 31
-hour 0 .. 23
-min 0 .. 59
-sec 0 .. 61 [Allows for two leap seconds]
-picosec 0 .. (10^12)-1 [This could be over-precise?]
-yday 0 .. 365 [364 in non-Leap years]
-tz -43200 .. 43200 [Variation from UTC in seconds]
-\end{verbatim}
--}
-
--- | 'CalendarTime' is a user-readable and manipulable
--- representation of the internal 'ClockTime' type.
-
-data CalendarTime
- = CalendarTime {
- ctYear :: Int -- ^ Year (pre-Gregorian dates are inaccurate)
- , ctMonth :: Month -- ^ Month of the year
- , ctDay :: Int -- ^ Day of the month (1 to 31)
- , ctHour :: Int -- ^ Hour of the day (0 to 23)
- , ctMin :: Int -- ^ Minutes (0 to 59)
- , ctSec :: Int -- ^ Seconds (0 to 61, allowing for up to
- -- two leap seconds)
- , ctPicosec :: Integer -- ^ Picoseconds
- , ctWDay :: Day -- ^ Day of the week
- , ctYDay :: Int -- ^ Day of the year
- -- (0 to 364, or 365 in leap years)
- , ctTZName :: String -- ^ Name of the time zone
- , ctTZ :: Int -- ^ Variation from UTC in seconds
- , ctIsDST :: Bool -- ^ 'True' if Daylight Savings Time would
- -- be in effect, and 'False' otherwise
- }
- deriving (Eq,Ord,Read,Show)
-
--- | records the difference between two clock times in a user-readable way.
-
-data TimeDiff
- = TimeDiff {
- tdYear :: Int,
- tdMonth :: Int,
- tdDay :: Int,
- tdHour :: Int,
- tdMin :: Int,
- tdSec :: Int,
- tdPicosec :: Integer -- not standard
- }
- deriving (Eq,Ord,Read,Show)
-
--- | null time difference.
-
-noTimeDiff :: TimeDiff
-noTimeDiff = TimeDiff 0 0 0 0 0 0 0
-
--- -----------------------------------------------------------------------------
--- | returns the current time in its internal representation.
-
-getClockTime :: IO ClockTime
-#ifdef __HUGS__
-getClockTime = do
- (sec,usec) <- getClockTimePrim
- return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000))
-
-#elif HAVE_GETTIMEOFDAY
-getClockTime = do
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do
- throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr
- sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime
- usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime
- return (TOD (realToInteger sec) ((realToInteger usec) * 1000000))
-
-#elif HAVE_FTIME
-getClockTime = do
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do
- ftime p_timeb
- sec <- (#peek struct timeb,time) p_timeb :: IO CTime
- msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort
- return (TOD (realToInteger sec) (fromIntegral msec * 1000000000))
-
-#else /* use POSIX time() */
-getClockTime = do
- secs <- time nullPtr -- can't fail, according to POSIX
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (TOD (realToInteger secs) 0)
-
-#endif
-
--- -----------------------------------------------------------------------------
--- | @'addToClockTime' d t@ adds a time difference @d@ and a
--- clock time @t@ to yield a new clock time. The difference @d@
--- may be either positive or negative.
-
-addToClockTime :: TimeDiff -> ClockTime -> ClockTime
-addToClockTime (TimeDiff year mon day hour min sec psec)
- (TOD c_sec c_psec) =
- let
- sec_diff = toInteger sec +
- 60 * toInteger min +
- 3600 * toInteger hour +
- 24 * 3600 * toInteger day
- (d_sec, d_psec) = (c_psec + psec) `quotRem` 1000000000000
- cal = toUTCTime (TOD (c_sec + sec_diff + d_sec) d_psec)
- new_mon = fromEnum (ctMonth cal) + r_mon
- month' = fst tmp
- yr_diff = snd tmp
- tmp
- | new_mon < 0 = (toEnum (12 + new_mon), (-1))
- | new_mon > 11 = (toEnum (new_mon `mod` 12), 1)
- | otherwise = (toEnum new_mon, 0)
-
- (r_yr, r_mon) = mon `quotRem` 12
-
- year' = ctYear cal + year + r_yr + yr_diff
- in
- toClockTime cal{ctMonth=month', ctYear=year'}
-
--- | @'diffClockTimes' t1 t2@ returns the difference between two clock
--- times @t1@ and @t2@ as a 'TimeDiff'.
-
-diffClockTimes :: ClockTime -> ClockTime -> TimeDiff
--- diffClockTimes is meant to be the dual to `addToClockTime'.
--- If you want to have the TimeDiff properly splitted, use
--- `normalizeTimeDiff' on this function's result
---
--- CAVEAT: see comment of normalizeTimeDiff
-diffClockTimes (TOD sa pa) (TOD sb pb) =
- noTimeDiff{ tdSec = fromIntegral (sa - sb)
- -- FIXME: can handle just 68 years...
- , tdPicosec = pa - pb
- }
-
-
--- | converts a time difference to normal form.
-
-normalizeTimeDiff :: TimeDiff -> TimeDiff
--- FIXME: handle psecs properly
--- FIXME: ?should be called by formatTimeDiff automagically?
---
--- when applied to something coming out of `diffClockTimes', you loose
--- the duality to `addToClockTime', since a year does not always have
--- 365 days, etc.
---
--- apply this function as late as possible to prevent those "rounding"
--- errors
-normalizeTimeDiff td =
- let
- rest0 = toInteger (tdSec td)
- + 60 * (toInteger (tdMin td)
- + 60 * (toInteger (tdHour td)
- + 24 * (toInteger (tdDay td)
- + 30 * toInteger (tdMonth td)
- + 365 * toInteger (tdYear td))))
-
- (diffYears, rest1) = rest0 `quotRem` (365 * 24 * 3600)
- (diffMonths, rest2) = rest1 `quotRem` (30 * 24 * 3600)
- (diffDays, rest3) = rest2 `quotRem` (24 * 3600)
- (diffHours, rest4) = rest3 `quotRem` 3600
- (diffMins, diffSecs) = rest4 `quotRem` 60
- in
- td{ tdYear = fromInteger diffYears
- , tdMonth = fromInteger diffMonths
- , tdDay = fromInteger diffDays
- , tdHour = fromInteger diffHours
- , tdMin = fromInteger diffMins
- , tdSec = fromInteger diffSecs
- }
-
-#ifndef __HUGS__
--- -----------------------------------------------------------------------------
--- How do we deal with timezones on this architecture?
-
--- The POSIX way to do it is through the global variable tzname[].
--- But that's crap, so we do it The BSD Way if we can: namely use the
--- tm_zone and tm_gmtoff fields of struct tm, if they're available.
-
-zone :: Ptr CTm -> IO (Ptr CChar)
-gmtoff :: Ptr CTm -> IO CLong
-#if HAVE_TM_ZONE
-zone x = (#peek struct tm,tm_zone) x
-gmtoff x = (#peek struct tm,tm_gmtoff) x
-
-#else /* ! HAVE_TM_ZONE */
-# if HAVE_TZNAME || defined(_WIN32)
-# if cygwin32_HOST_OS
-# define tzname _tzname
-# endif
-# ifndef mingw32_HOST_OS
-foreign import ccall unsafe "time.h &tzname" tzname :: Ptr CString
-# else
-foreign import ccall unsafe "__hscore_timezone" timezone :: Ptr CLong
-foreign import ccall unsafe "__hscore_tzname" tzname :: Ptr CString
-# endif
-zone x = do
- dst <- (#peek struct tm,tm_isdst) x
- if dst then peekElemOff tzname 1 else peekElemOff tzname 0
-# else /* ! HAVE_TZNAME */
--- We're in trouble. If you should end up here, please report this as a bug.
-# error "Don't know how to get at timezone name on your OS."
-# endif /* ! HAVE_TZNAME */
-
--- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */
-# if HAVE_DECL_ALTZONE
-foreign import ccall "&altzone" altzone :: Ptr CTime
-foreign import ccall "&timezone" timezone :: Ptr CTime
-gmtoff x = do
- dst <- (#peek struct tm,tm_isdst) x
- tz <- if dst then peek altzone else peek timezone
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- return (-fromIntegral (realToInteger tz))
-# else /* ! HAVE_DECL_ALTZONE */
-
-#if !defined(mingw32_HOST_OS)
-foreign import ccall "time.h &timezone" timezone :: Ptr CLong
-#endif
-
--- Assume that DST offset is 1 hour ...
-gmtoff x = do
- dst <- (#peek struct tm,tm_isdst) x
- tz <- peek timezone
- -- According to the documentation for tzset(),
- -- http://www.opengroup.org/onlinepubs/007908799/xsh/tzset.html
- -- timezone offsets are > 0 west of the Prime Meridian.
- --
- -- This module assumes the interpretation of tm_gmtoff, i.e., offsets
- -- are > 0 East of the Prime Meridian, so flip the sign.
- return (- (if dst then (fromIntegral tz - 3600) else tz))
-# endif /* ! HAVE_DECL_ALTZONE */
-#endif /* ! HAVE_TM_ZONE */
-#endif /* ! __HUGS__ */
-
--- -----------------------------------------------------------------------------
--- | converts an internal clock time to a local time, modified by the
--- timezone and daylight savings time settings in force at the time
--- of conversion. Because of this dependence on the local environment,
--- 'toCalendarTime' is in the 'IO' monad.
-
-toCalendarTime :: ClockTime -> IO CalendarTime
-#ifdef __HUGS__
-toCalendarTime = toCalTime False
-#elif HAVE_LOCALTIME_R
-toCalendarTime = clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False
-#else
-toCalendarTime = clockToCalendarTime_static localtime False
-#endif
-
--- | converts an internal clock time into a 'CalendarTime' in standard
--- UTC format.
-
-toUTCTime :: ClockTime -> CalendarTime
-#ifdef __HUGS__
-toUTCTime = unsafePerformIO . toCalTime True
-#elif HAVE_GMTIME_R
-toUTCTime = unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True
-#else
-toUTCTime = unsafePerformIO . clockToCalendarTime_static gmtime True
-#endif
-
-#ifdef __HUGS__
-toCalTime :: Bool -> ClockTime -> IO CalendarTime
-toCalTime toUTC (TOD s psecs)
- | (s > fromIntegral (maxBound :: Int)) ||
- (s < fromIntegral (minBound :: Int))
- = error ((if toUTC then "toUTCTime: " else "toCalendarTime: ") ++
- "clock secs out of range")
- | otherwise = do
- (sec,min,hour,mday,mon,year,wday,yday,isdst,zone,off) <-
- toCalTimePrim (if toUTC then 1 else 0) (fromIntegral s)
- return (CalendarTime{ ctYear=1900+year
- , ctMonth=toEnum mon
- , ctDay=mday
- , ctHour=hour
- , ctMin=min
- , ctSec=sec
- , ctPicosec=psecs
- , ctWDay=toEnum wday
- , ctYDay=yday
- , ctTZName=(if toUTC then "UTC" else zone)
- , ctTZ=(if toUTC then 0 else off)
- , ctIsDST=not toUTC && (isdst/=0)
- })
-#else /* ! __HUGS__ */
-throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm))
- -> (Ptr CTime -> Ptr CTm -> IO ( ))
-throwAwayReturnPointer fun x y = fun x y >> return ()
-
-#if !HAVE_LOCALTIME_R || !HAVE_GMTIME_R
-clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime
- -> IO CalendarTime
-clockToCalendarTime_static fun is_utc (TOD secs psec) = do
- with (fromIntegral secs :: CTime) $ \ p_timer -> do
- p_tm <- fun p_timer -- can't fail, according to POSIX
- clockToCalendarTime_aux is_utc p_tm psec
-#endif
-
-#if HAVE_LOCALTIME_R || HAVE_GMTIME_R
-clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime
- -> IO CalendarTime
-clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do
- with (fromIntegral secs :: CTime) $ \ p_timer -> do
- allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
- fun p_timer p_tm
- clockToCalendarTime_aux is_utc p_tm psec
-#endif
-
-clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime
-clockToCalendarTime_aux is_utc p_tm psec = do
- sec <- (#peek struct tm,tm_sec ) p_tm :: IO CInt
- min <- (#peek struct tm,tm_min ) p_tm :: IO CInt
- hour <- (#peek struct tm,tm_hour ) p_tm :: IO CInt
- mday <- (#peek struct tm,tm_mday ) p_tm :: IO CInt
- mon <- (#peek struct tm,tm_mon ) p_tm :: IO CInt
- year <- (#peek struct tm,tm_year ) p_tm :: IO CInt
- wday <- (#peek struct tm,tm_wday ) p_tm :: IO CInt
- yday <- (#peek struct tm,tm_yday ) p_tm :: IO CInt
- isdst <- (#peek struct tm,tm_isdst) p_tm :: IO CInt
- zone <- zone p_tm
- tz <- gmtoff p_tm
-
- tzname <- peekCString zone
-
- let month | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon)
- | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon)
-
- return (CalendarTime
- (1900 + fromIntegral year)
- month
- (fromIntegral mday)
- (fromIntegral hour)
- (fromIntegral min)
- (fromIntegral sec)
- psec
- (toEnum (fromIntegral wday))
- (fromIntegral yday)
- (if is_utc then "UTC" else tzname)
- (if is_utc then 0 else fromIntegral tz)
- (if is_utc then False else isdst /= 0))
-#endif /* ! __HUGS__ */
-
--- | converts a 'CalendarTime' into the corresponding internal
--- 'ClockTime', ignoring the contents of the 'ctWDay', 'ctYDay',
--- 'ctTZName' and 'ctIsDST' fields.
-
-toClockTime :: CalendarTime -> ClockTime
-#ifdef __HUGS__
-toClockTime (CalendarTime yr mon mday hour min sec psec
- _wday _yday _tzname tz _isdst) =
- unsafePerformIO $ do
- s <- toClockTimePrim (yr-1900) (fromEnum mon) mday hour min sec tz
- return (TOD (fromIntegral s) psec)
-#else /* ! __HUGS__ */
-toClockTime (CalendarTime year mon mday hour min sec psec
- _wday _yday _tzname tz isdst) =
-
- -- `isDst' causes the date to be wrong by one hour...
- -- FIXME: check, whether this works on other arch's than Linux, too...
- --
- -- so we set it to (-1) (means `unknown') and let `mktime' determine
- -- the real value...
- let isDst = -1 :: CInt in -- if isdst then (1::Int) else 0
-
- if psec < 0 || psec > 999999999999 then
- error "Time.toClockTime: picoseconds out of range"
- else if tz < -43200 || tz > 43200 then
- error "Time.toClockTime: timezone offset out of range"
- else
- unsafePerformIO $ do
- allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
- (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)
- (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)
- (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
- (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)
- (#poke struct tm,tm_mon ) p_tm (fromIntegral (fromEnum mon) :: CInt)
- (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt)
- (#poke struct tm,tm_isdst) p_tm isDst
- t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input")
- (mktime p_tm)
- --
- -- mktime expects its argument to be in the local timezone, but
- -- toUTCTime makes UTC-encoded CalendarTime's ...
- --
- -- Since there is no any_tz_struct_tm-to-time_t conversion
- -- function, we have to fake one... :-) If not in all, it works in
- -- most cases (before, it was the other way round...)
- --
- -- Luckily, mktime tells us, what it *thinks* the timezone is, so,
- -- to compensate, we add the timezone difference to mktime's
- -- result.
- --
- gmtoff <- gmtoff p_tm
- let realToInteger = round . realToFrac :: Real a => a -> Integer
- res = realToInteger t - fromIntegral tz + fromIntegral gmtoff
- return (TOD res psec)
-#endif /* ! __HUGS__ */
-
--- -----------------------------------------------------------------------------
--- Converting time values to strings.
-
--- | formats calendar times using local conventions.
-
-calendarTimeToString :: CalendarTime -> String
-calendarTimeToString = formatCalendarTime defaultTimeLocale "%c"
-
--- | formats calendar times using local conventions and a formatting string.
--- The formatting string is that understood by the ISO C @strftime()@
--- function.
-
-formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
-formatCalendarTime l fmt (CalendarTime year mon day hour min sec _
- wday yday tzname _ _) =
- doFmt fmt
- where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':c:cs) = decode c ++ doFmt cs
- doFmt (c:cs) = c : doFmt cs
- doFmt "" = ""
-
- decode 'A' = fst (wDays l !! fromEnum wday) -- day of the week, full name
- decode 'a' = snd (wDays l !! fromEnum wday) -- day of the week, abbrev.
- decode 'B' = fst (months l !! fromEnum mon) -- month, full name
- decode 'b' = snd (months l !! fromEnum mon) -- month, abbrev
- decode 'h' = snd (months l !! fromEnum mon) -- ditto
- decode 'C' = show2 (year `quot` 100) -- century
- decode 'c' = doFmt (dateTimeFmt l) -- locale's data and time format.
- decode 'D' = doFmt "%m/%d/%y"
- decode 'd' = show2 day -- day of the month
- decode 'e' = show2' day -- ditto, padded
- decode 'H' = show2 hour -- hours, 24-hour clock, padded
- decode 'I' = show2 (to12 hour) -- hours, 12-hour clock
- decode 'j' = show3 yday -- day of the year
- decode 'k' = show2' hour -- hours, 24-hour clock, no padding
- decode 'l' = show2' (to12 hour) -- hours, 12-hour clock, no padding
- decode 'M' = show2 min -- minutes
- decode 'm' = show2 (fromEnum mon+1) -- numeric month
- decode 'n' = "\n"
- decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm
- decode 'R' = doFmt "%H:%M"
- decode 'r' = doFmt (time12Fmt l)
- decode 'T' = doFmt "%H:%M:%S"
- decode 't' = "\t"
- decode 'S' = show2 sec -- seconds
- decode 's' = show2 sec -- number of secs since Epoch. (ToDo.)
- decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday.
- decode 'u' = show (let n = fromEnum wday in -- numeric day of the week (1=Monday, 7=Sunday)
- if n == 0 then 7 else n)
- decode 'V' = -- week number (as per ISO-8601.)
- let (week, days) = -- [yep, I've always wanted to be able to display that too.]
- (yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `divMod` 7
- in show2 (if days >= 4 then
- week+1
- else if week == 0 then 53 else week)
-
- decode 'W' = -- week number, weeks starting on monday
- show2 ((yday + 7 - if fromEnum wday > 0 then
- fromEnum wday - 1 else 6) `div` 7)
- decode 'w' = show (fromEnum wday) -- numeric day of the week, weeks starting on Sunday.
- decode 'X' = doFmt (timeFmt l) -- locale's preferred way of printing time.
- decode 'x' = doFmt (dateFmt l) -- locale's preferred way of printing dates.
- decode 'Y' = show year -- year, including century.
- decode 'y' = show2 (year `rem` 100) -- year, within century.
- decode 'Z' = tzname -- timezone name
- decode '%' = "%"
- decode c = [c]
-
-
-show2, show2', show3 :: Int -> String
-show2 x
- | x' < 10 = '0': show x'
- | otherwise = show x'
- where x' = x `rem` 100
-
-show2' x
- | x' < 10 = ' ': show x'
- | otherwise = show x'
- where x' = x `rem` 100
-
-show3 x = show (x `quot` 100) ++ show2 (x `rem` 100)
-
-to12 :: Int -> Int
-to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
-
--- Useful extensions for formatting TimeDiffs.
-
--- | formats time differences using local conventions.
-
-timeDiffToString :: TimeDiff -> String
-timeDiffToString = formatTimeDiff defaultTimeLocale "%c"
-
--- | formats time differences using local conventions and a formatting string.
--- The formatting string is that understood by the ISO C @strftime()@
--- function.
-
-formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String
-formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _)
- = doFmt fmt
- where
- doFmt "" = ""
- doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented
- doFmt ('%':c:cs) = decode c ++ doFmt cs
- doFmt (c:cs) = c : doFmt cs
-
- decode spec =
- case spec of
- 'B' -> fst (months l !! fromEnum month)
- 'b' -> snd (months l !! fromEnum month)
- 'h' -> snd (months l !! fromEnum month)
- 'c' -> defaultTimeDiffFmt td
- 'C' -> show2 (year `quot` 100)
- 'D' -> doFmt "%m/%d/%y"
- 'd' -> show2 day
- 'e' -> show2' day
- 'H' -> show2 hour
- 'I' -> show2 (to12 hour)
- 'k' -> show2' hour
- 'l' -> show2' (to12 hour)
- 'M' -> show2 min
- 'm' -> show2 (fromEnum month + 1)
- 'n' -> "\n"
- 'p' -> (if hour < 12 then fst else snd) (amPm l)
- 'R' -> doFmt "%H:%M"
- 'r' -> doFmt (time12Fmt l)
- 'T' -> doFmt "%H:%M:%S"
- 't' -> "\t"
- 'S' -> show2 sec
- 's' -> show2 sec -- Implementation-dependent, sez the lib doc..
- 'X' -> doFmt (timeFmt l)
- 'x' -> doFmt (dateFmt l)
- 'Y' -> show year
- 'y' -> show2 (year `rem` 100)
- '%' -> "%"
- c -> [c]
-
- defaultTimeDiffFmt (TimeDiff year month day hour min sec _) =
- foldr (\ (v,s) rest ->
- (if v /= 0
- then show v ++ ' ':(addS v s)
- ++ if null rest then "" else ", "
- else "") ++ rest
- )
- ""
- (zip [year, month, day, hour, min, sec] (intervals l))
-
- addS v s = if abs v == 1 then fst s else snd s
-
-#ifndef __HUGS__
--- -----------------------------------------------------------------------------
--- Foreign time interface (POSIX)
-
-type CTm = () -- struct tm
-
-#if HAVE_LOCALTIME_R
-foreign import ccall unsafe "time.h localtime_r"
- localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
-#else
-foreign import ccall unsafe "time.h localtime"
- localtime :: Ptr CTime -> IO (Ptr CTm)
-#endif
-#if HAVE_GMTIME_R
-foreign import ccall unsafe "time.h gmtime_r"
- gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm)
-#else
-foreign import ccall unsafe "time.h gmtime"
- gmtime :: Ptr CTime -> IO (Ptr CTm)
-#endif
-foreign import ccall unsafe "time.h mktime"
- mktime :: Ptr CTm -> IO CTime
-
-#if HAVE_GETTIMEOFDAY
-type CTimeVal = ()
-type CTimeZone = ()
-foreign import ccall unsafe "time.h gettimeofday"
- gettimeofday :: Ptr CTimeVal -> Ptr CTimeZone -> IO CInt
-#elif HAVE_FTIME
-type CTimeB = ()
-#ifndef mingw32_HOST_OS
-foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO CInt
-#else
-foreign import ccall unsafe "time.h ftime" ftime :: Ptr CTimeB -> IO ()
-#endif
-#else
-foreign import ccall unsafe "time.h time" time :: Ptr CTime -> IO CTime
-#endif
-#endif /* ! __HUGS__ */
-# FP_DECL_ALTZONE
-# ---------------
-# Defines HAVE_DECL_ALTZONE to 1 if declared, 0 otherwise.
-#
-# Used by base package.
-AC_DEFUN([FP_DECL_ALTZONE],
-[AC_REQUIRE([AC_HEADER_TIME])dnl
-AC_CHECK_HEADERS([sys/time.h])
-AC_CHECK_DECLS([altzone], [], [],[#if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif])
-])# FP_DECL_ALTZONE
-
-
# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS)
# --------------------------------------------------------
# Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for
System.Cmd,
System.Console.GetOpt,
System.CPUTime,
- System.Directory,
- System.Directory.Internals,
System.Environment,
System.Exit,
System.IO,
System.Posix.Types,
System.Process,
System.Process.Internals,
- System.Random,
- System.Time,
Text.ParserCombinators.ReadP,
Text.ParserCombinators.ReadPrec,
Text.Printf,
cbits/longlong.c
cbits/runProcess.c
cbits/selectUtils.c
- cbits/timeUtils.c
include-dirs: include, ../../includes, ../../rts
includes: HsBase.h
install-includes: HsBase.h
#endif
}
-/*
- * Function: __hscore_getFolderPath()
- *
- * Late-bound version of SHGetFolderPath(), coping with OS versions
- * that have shell32's lacking that particular API.
- *
- */
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-typedef HRESULT (*HSCORE_GETAPPFOLDERFUNTY)(HWND,int,HANDLE,DWORD,char*);
-int
-__hscore_getFolderPath(HWND hwndOwner,
- int nFolder,
- HANDLE hToken,
- DWORD dwFlags,
- char* pszPath)
-{
- static int loaded_dll = 0;
- static HMODULE hMod = (HMODULE)NULL;
- static HSCORE_GETAPPFOLDERFUNTY funcPtr = NULL;
- /* The DLLs to try loading entry point from */
- char* dlls[] = { "shell32.dll", "shfolder.dll" };
-
- if (loaded_dll < 0) {
- return (-1);
- } else if (loaded_dll == 0) {
- int i;
- for(i=0;i < sizeof(dlls); i++) {
- hMod = LoadLibrary(dlls[i]);
- if ( hMod != NULL &&
- (funcPtr = (HSCORE_GETAPPFOLDERFUNTY)GetProcAddress(hMod, "SHGetFolderPathA")) ) {
- loaded_dll = 1;
- break;
- }
- }
- if (loaded_dll == 0) {
- loaded_dll = (-1);
- return (-1);
- }
- }
- /* OK, if we got this far the function has been bound */
- return (int)funcPtr(hwndOwner,nFolder,hToken,dwFlags,pszPath);
- /* ToDo: unload the DLL on shutdown? */
-}
-#endif
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Time Runtime Support
- */
-#include "HsBase.h"
-
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) /* to the end */
-
-long *__hscore_timezone( void )
-{ return &_timezone; }
-
-char **__hscore_tzname( void )
-{ return _tzname; }
-#endif
dnl functions if it's really there.
AC_CHECK_HEADERS([wctype.h], [AC_CHECK_FUNCS(iswspace)])
-AC_CHECK_FUNCS([ftime gmtime_r localtime_r lstat readdir_r])
-AC_CHECK_FUNCS([getclock getrusage gettimeofday setitimer times])
+AC_CHECK_FUNCS([lstat readdir_r])
+AC_CHECK_FUNCS([getclock getrusage setitimer times])
AC_CHECK_FUNCS([_chsize ftruncate])
-dnl ** check if it is safe to include both <time.h> and <sys/time.h>
-AC_HEADER_TIME
-
-dnl ** how do we get a timezone name, and UTC offset ?
-AC_STRUCT_TIMEZONE
-
-dnl ** do we have altzone?
-FP_DECL_ALTZONE
-
# map standard C types and ISO types to Haskell types
FPTOOLS_CHECK_HTYPE(char)
FPTOOLS_CHECK_HTYPE(signed char)
#if defined(__MINGW32__)
#include <io.h>
#include <fcntl.h>
-#include "timeUtils.h"
#include <shlobj.h>
#include <share.h>
#endif
#endif
}
-#ifdef PATH_MAX
-/* A size that will contain many path names, but not necessarily all
- * (PATH_MAX is not defined on systems with unlimited path length,
- * e.g. the Hurd).
- */
-INLINE HsInt __hscore_long_path_size() { return PATH_MAX; }
-#else
-INLINE HsInt __hscore_long_path_size() { return 4096; }
-#endif
-
-#ifdef R_OK
-INLINE int __hscore_R_OK() { return R_OK; }
-#endif
-#ifdef W_OK
-INLINE int __hscore_W_OK() { return W_OK; }
-#endif
-#ifdef X_OK
-INLINE int __hscore_X_OK() { return X_OK; }
-#endif
-
-#ifdef S_IRUSR
-INLINE mode_t __hscore_S_IRUSR() { return S_IRUSR; }
-#endif
-#ifdef S_IWUSR
-INLINE mode_t __hscore_S_IWUSR() { return S_IWUSR; }
-#endif
-#ifdef S_IXUSR
-INLINE mode_t __hscore_S_IXUSR() { return S_IXUSR; }
-#endif
-
INLINE char *
__hscore_d_name( struct dirent* d )
{
}
#endif /* !defined(__MINGW32__) */
-// Directory-related
-
-#if defined(__MINGW32__)
-
-/* Make sure we've got the reqd CSIDL_ constants in scope;
- * w32api header files are lagging a bit in defining the full set.
- */
-#if !defined(CSIDL_APPDATA)
-#define CSIDL_APPDATA 0x001a
-#endif
-#if !defined(CSIDL_PERSONAL)
-#define CSIDL_PERSONAL 0x0005
-#endif
-#if !defined(CSIDL_PROFILE)
-#define CSIDL_PROFILE 0x0028
-#endif
-#if !defined(CSIDL_WINDOWS)
-#define CSIDL_WINDOWS 0x0024
-#endif
-
-INLINE int __hscore_CSIDL_PROFILE() { return CSIDL_PROFILE; }
-INLINE int __hscore_CSIDL_APPDATA() { return CSIDL_APPDATA; }
-INLINE int __hscore_CSIDL_WINDOWS() { return CSIDL_WINDOWS; }
-INLINE int __hscore_CSIDL_PERSONAL() { return CSIDL_PERSONAL; }
-#endif
-
#if defined(__MINGW32__)
INLINE unsigned int __hscore_get_osver(void) { return _osver; }
#endif
extern int __hscore_readdir(DIR *dirPtr, struct dirent **pDirEnt);
extern int __hscore_renameFile(char *src, char *dest);
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
-extern int __hscore_getFolderPath(HWND hwndOwner,
- int nFolder,
- HANDLE hToken,
- DWORD dwFlags,
- char* pszPath);
-#endif
-
#endif /* __DIRUTILS_H__ */
+++ /dev/null
-/*
- * (c) The University of Glasgow 2002
- *
- * Time Runtime Support
- */
-#ifndef __TIMEUTILS_H__
-#define __TIMEUTILS_H__
-
-extern long *__hscore_timezone( void );
-extern char **__hscore_tzname( void );
-
-#endif /* __DIRUTILS_H__ */
projects / ghc-base.git / commitdiff