diff options
| -rw-r--r-- | libraries/base/GHC/Handle.hs | 9 | ||||
| -rw-r--r-- | libraries/base/System/Directory.hs | 1044 | ||||
| -rw-r--r-- | libraries/base/System/Directory/Internals.hs | 186 | ||||
| -rw-r--r-- | libraries/base/System/Random.hs | 449 | ||||
| -rw-r--r-- | libraries/base/System/Time.hsc | 756 | ||||
| -rw-r--r-- | libraries/base/aclocal.m4 | 21 | ||||
| -rw-r--r-- | libraries/base/base.cabal | 5 | ||||
| -rw-r--r-- | libraries/base/cbits/dirUtils.c | 44 | ||||
| -rw-r--r-- | libraries/base/cbits/timeUtils.c | 15 | ||||
| -rw-r--r-- | libraries/base/configure.ac | 13 | ||||
| -rw-r--r-- | libraries/base/include/HsBase.h | 57 | ||||
| -rw-r--r-- | libraries/base/include/dirUtils.h | 8 | ||||
| -rw-r--r-- | libraries/base/include/timeUtils.h | 12 |
13 files changed, 9 insertions, 2610 deletions
diff --git a/libraries/base/GHC/Handle.hs b/libraries/base/GHC/Handle.hs index cb6d5de938..ebcd75e872 100644 --- a/libraries/base/GHC/Handle.hs +++ b/libraries/base/GHC/Handle.hs @@ -55,7 +55,6 @@ module GHC.Handle ( ) where -import System.Directory.Internals import Control.Monad import Data.Bits import Data.Maybe @@ -945,8 +944,14 @@ openTempFile' loc tmp_dir template binary = do 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 diff --git a/libraries/base/System/Directory.hs b/libraries/base/System/Directory.hs deleted file mode 100644 index 90de6fa503..0000000000 --- a/libraries/base/System/Directory.hs +++ /dev/null @@ -1,1044 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 diff --git a/libraries/base/System/Directory/Internals.hs b/libraries/base/System/Directory/Internals.hs deleted file mode 100644 index c763764974..0000000000 --- a/libraries/base/System/Directory/Internals.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# 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 - diff --git a/libraries/base/System/Random.hs b/libraries/base/System/Random.hs deleted file mode 100644 index 8b648a7365..0000000000 --- a/libraries/base/System/Random.hs +++ /dev/null @@ -1,449 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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. - --} diff --git a/libraries/base/System/Time.hsc b/libraries/base/System/Time.hsc deleted file mode 100644 index a2c6b5b249..0000000000 --- a/libraries/base/System/Time.hsc +++ /dev/null @@ -1,756 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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__ */ diff --git a/libraries/base/aclocal.m4 b/libraries/base/aclocal.m4 index 16d8bb983d..49ad919af3 100644 --- a/libraries/base/aclocal.m4 +++ b/libraries/base/aclocal.m4 @@ -1,24 +1,3 @@ -# 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 diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index b1ad318edd..10e78499bd 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -138,8 +138,6 @@ exposed-modules: System.Cmd, System.Console.GetOpt, System.CPUTime, - System.Directory, - System.Directory.Internals, System.Environment, System.Exit, System.IO, @@ -155,8 +153,6 @@ exposed-modules: System.Posix.Types, System.Process, System.Process.Internals, - System.Random, - System.Time, Text.ParserCombinators.ReadP, Text.ParserCombinators.ReadPrec, Text.Printf, @@ -180,7 +176,6 @@ c-sources: cbits/longlong.c cbits/runProcess.c cbits/selectUtils.c - cbits/timeUtils.c include-dirs: include, ../../includes, ../../rts includes: HsBase.h install-includes: HsBase.h diff --git a/libraries/base/cbits/dirUtils.c b/libraries/base/cbits/dirUtils.c index d6da255a8b..90c8ab8185 100644 --- a/libraries/base/cbits/dirUtils.c +++ b/libraries/base/cbits/dirUtils.c @@ -171,47 +171,3 @@ __hscore_renameFile( char *src, char *dest) #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 diff --git a/libraries/base/cbits/timeUtils.c b/libraries/base/cbits/timeUtils.c deleted file mode 100644 index 64d50449a5..0000000000 --- a/libraries/base/cbits/timeUtils.c +++ /dev/null @@ -1,15 +0,0 @@ -/* - * (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 diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac index e318cf5b75..66569a773d 100644 --- a/libraries/base/configure.ac +++ b/libraries/base/configure.ac @@ -34,19 +34,10 @@ dnl FreeBSD has an emtpy wctype.h, so test one of the affected 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) diff --git a/libraries/base/include/HsBase.h b/libraries/base/include/HsBase.h index 5b74dbb0c1..8c9fa21b7a 100644 --- a/libraries/base/include/HsBase.h +++ b/libraries/base/include/HsBase.h @@ -140,7 +140,6 @@ extern HsWord64 getUSecOfDay(void); #if defined(__MINGW32__) #include <io.h> #include <fcntl.h> -#include "timeUtils.h" #include <shlobj.h> #include <share.h> #endif @@ -481,36 +480,6 @@ __hscore_lstat( const char *fname, struct stat *st ) #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 ) { @@ -736,32 +705,6 @@ INLINE void setTimevalTicks(struct timeval *p, HsWord64 usecs) } #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 diff --git a/libraries/base/include/dirUtils.h b/libraries/base/include/dirUtils.h index b726402c66..a5171d86c4 100644 --- a/libraries/base/include/dirUtils.h +++ b/libraries/base/include/dirUtils.h @@ -9,12 +9,4 @@ 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__ */ diff --git a/libraries/base/include/timeUtils.h b/libraries/base/include/timeUtils.h deleted file mode 100644 index c98450e52a..0000000000 --- a/libraries/base/include/timeUtils.h +++ /dev/null @@ -1,12 +0,0 @@ -/* - * (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__ */ |