directory 1.2.1.0 → 1.2.2.0
raw patch · 52 files changed
+1058/−287 lines, 52 filesdep +directorydep ~basedep ~filepathsetup-changednew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: directory
Dependency ranges changed: base, filepath
API changes (from Hackage documentation)
+ System.Directory: findExecutables :: String -> IO [FilePath]
+ System.Directory: instance Enum DirectoryType
+ System.Directory: instance Eq DirectoryType
+ System.Directory: instance Ord DirectoryType
+ System.Directory: instance Read DirectoryType
+ System.Directory: instance Show DirectoryType
+ System.Directory: makeAbsolute :: FilePath -> IO FilePath
Files
- README.md +23/−0
- Setup.hs +1/−1
- System/Directory.hs +159/−94
- changelog.md +36/−2
- config.guess +27/−165
- config.sub +13/−10
- directory.cabal +38/−15
- tests/Makefile +7/−0
- tests/T8482.hs +16/−0
- tests/T8482.stdout +3/−0
- tests/TestUtils.hs +86/−0
- tests/all.T +32/−0
- tests/canonicalizePath001.hs +8/−0
- tests/canonicalizePath001.stdout +1/−0
- tests/copyFile001.hs +26/−0
- tests/copyFile001.stdout +5/−0
- tests/copyFile001dir/source +1/−0
- tests/copyFile002.hs +31/−0
- tests/copyFile002.stdout +5/−0
- tests/copyFile002dir/source +1/−0
- tests/createDirectory001.hs +12/−0
- tests/createDirectory001.stdout +1/−0
- tests/createDirectory001.stdout-mingw32 +1/−0
- tests/createDirectoryIfMissing001.hs +79/−0
- tests/createDirectoryIfMissing001.stdout +8/−0
- tests/createDirectoryIfMissing001.stdout-mingw32 +8/−0
- tests/currentDirectory001.hs +27/−0
- tests/currentDirectory001.stdout +1/−0
- tests/directory001.hs +16/−0
- tests/directory001.stdout +1/−0
- tests/doesDirectoryExist001.hs +11/−0
- tests/doesDirectoryExist001.stdout +1/−0
- tests/getDirContents001.hs +18/−0
- tests/getDirContents001.stdout +2/−0
- tests/getDirContents002.hs +3/−0
- tests/getDirContents002.stderr +1/−0
- tests/getDirContents002.stderr-mingw32 +1/−0
- tests/getHomeDirectory001.hs +8/−0
- tests/getPermissions001.hs +20/−0
- tests/getPermissions001.stdout +3/−0
- tests/getPermissions001.stdout-alpha-dec-osf3 +3/−0
- tests/getPermissions001.stdout-i386-unknown-freebsd +3/−0
- tests/getPermissions001.stdout-i386-unknown-openbsd +3/−0
- tests/getPermissions001.stdout-mingw +3/−0
- tests/getPermissions001.stdout-x86_64-unknown-openbsd +3/−0
- tests/removeDirectoryRecursive001.hs +93/−0
- tests/removeDirectoryRecursive001.stdout +19/−0
- tests/renameFile001.hs +13/−0
- tests/renameFile001.stdout +2/−0
- tools/dispatch-tests.hs +63/−0
- tools/ghc.patch +62/−0
- tools/run-tests +50/−0
+ README.md view
@@ -0,0 +1,23 @@+`directory` [![Hackage][1]][2] [![Build Status][3]][4]+===========++Documentation can be found on [Hackage][2].++Building from Git repository+----------------------------++When building this package directly from the Git repository, one must run+`autoreconf -i` to generate the `configure` script needed by `cabal+configure`. This requires [Autoconf][5] to be installed.++ autoreconf -i+ cabal install++There is no need to run the `configure` script manually however, as `cabal+configure` does that automatically.++[1]: https://img.shields.io/hackage/v/directory.svg+[2]: https://hackage.haskell.org/package/directory+[3]: https://travis-ci.org/haskell/directory.svg?branch=master+[4]: https://travis-ci.org/haskell/directory+[5]: https://gnu.org/software/autoconf
Setup.hs view
@@ -3,4 +3,4 @@ import Distribution.Simple main :: IO ()-main = defaultMainWithHooks defaultUserHooks+main = defaultMainWithHooks autoconfUserHooks
System/Directory.hs view
@@ -44,8 +44,10 @@ , copyFile , canonicalizePath+ , makeAbsolute , makeRelativeToCurrentDirectory , findExecutable+ , findExecutables , findFile , findFiles , findFilesWith@@ -95,8 +97,8 @@ import Data.Maybe -import Data.Time-import Data.Time.Clock.POSIX+import Data.Time ( UTCTime )+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime ) #ifdef __GLASGOW_HASKELL__ @@ -196,7 +198,8 @@ getPermissions :: FilePath -> IO Permissions getPermissions name = do #ifdef mingw32_HOST_OS- withFilePath name $ \s -> do+ -- issue #9: Windows doesn't like trailing path separators+ withFilePath (dropTrailingPathSeparator name) $ \s -> do -- stat() does a better job of guessing the permissions on Windows -- than access() does. e.g. for execute permission, it looks at the -- filename extension :-)@@ -366,11 +369,11 @@ parents = reverse . scanl1 (</>) . splitDirectories . normalise createDirs [] = return ()- createDirs (dir:[]) = createDir dir throw+ createDirs (dir:[]) = createDir dir throwIO createDirs (dir:dirs) = createDir dir $ \_ -> do createDirs dirs- createDir dir throw+ createDir dir throwIO createDir :: FilePath -> (IOException -> IO ()) -> IO () createDir dir notExistHandler = do@@ -393,22 +396,45 @@ -- This caused GHCi to crash when loading a module in the root -- directory. | isAlreadyExistsError e- || isPermissionError e -> (do+ || isPermissionError e -> do #ifdef mingw32_HOST_OS- withFileStatus "createDirectoryIfMissing" dir $ \st -> do- isDir <- isDirectory st- if isDir then return ()- else throw e+ canIgnore <- (withFileStatus "createDirectoryIfMissing" dir isDirectory) #else- stat <- Posix.getFileStatus dir- if Posix.isDirectory stat- then return ()- else throw e+ canIgnore <- (Posix.isDirectory `fmap` Posix.getFileStatus dir) #endif- ) `E.catch` ((\_ -> return ()) :: IOException -> IO ())- | otherwise -> throw e+ `E.catch` ((\ _ -> return (isAlreadyExistsError e))+ :: IOException -> IO Bool)+ unless canIgnore (throwIO e)+ | otherwise -> throwIO e #if __GLASGOW_HASKELL__++-- | * @'NotDirectory'@: not a directory.+-- * @'Directory'@: a true directory (not a symbolic link).+-- * @'DirectoryLink'@: a directory symbolic link (only exists on Windows).+data DirectoryType = NotDirectory+ | Directory+ | DirectoryLink+ deriving (Enum, Eq, Ord, Read, Show)++-- | Obtain the type of a directory.+getDirectoryType :: FilePath -> IO DirectoryType+getDirectoryType path =+ (`ioeSetLocation` "getDirectoryType") `modifyIOError` do+#ifdef mingw32_HOST_OS+ fmap classify (Win32.getFileAttributes path)+ where fILE_ATTRIBUTE_REPARSE_POINT = 0x400+ classify attr+ | attr .&. Win32.fILE_ATTRIBUTE_DIRECTORY == 0 = NotDirectory+ | attr .&. fILE_ATTRIBUTE_REPARSE_POINT == 0 = Directory+ | otherwise = DirectoryLink+#else+ stat <- Posix.getSymbolicLinkStatus path+ return $ if Posix.isDirectory stat+ then Directory+ else NotDirectory+#endif+ {- | @'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@@ -460,24 +486,40 @@ #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' dir@ removes an existing directory /dir/+-- together with its contents and subdirectories. Symbolic links are removed+-- without affecting their the targets. removeDirectoryRecursive :: FilePath -> IO ()-removeDirectoryRecursive startLoc = do- cont <- getDirectoryContents startLoc- sequence_ [rm (startLoc </> x) | x <- cont, x /= "." && x /= ".."]- removeDirectory startLoc- where- rm :: FilePath -> IO ()- rm f = do temp <- E.try (removeFile f)- case temp of- Left e -> do isDir <- doesDirectoryExist f- -- If f is not a directory, re-throw the error- unless isDir $ throw (e :: SomeException)- removeDirectoryRecursive f- Right _ -> return ()+removeDirectoryRecursive path =+ (`ioeSetLocation` "removeDirectoryRecursive") `modifyIOError` do+ dirType <- getDirectoryType path+ case dirType of+ Directory -> removeContentsRecursive path+ _ -> ioError . (`ioeSetErrorString` "not a directory") $+ mkIOError InappropriateType "" Nothing (Just path) +-- | @'removePathRecursive' path@ removes an existing file or directory at+-- /path/ together with its contents and subdirectories. Symbolic links are+-- removed without affecting their the targets.+removePathRecursive :: FilePath -> IO ()+removePathRecursive path =+ (`ioeSetLocation` "removePathRecursive") `modifyIOError` do+ dirType <- getDirectoryType path+ case dirType of+ NotDirectory -> removeFile path+ Directory -> removeContentsRecursive path+ DirectoryLink -> removeDirectory path++-- | @'removeContentsRecursive' dir@ removes the contents of the directory+-- /dir/ recursively. Symbolic links are removed without affecting their the+-- targets.+removeContentsRecursive :: FilePath -> IO ()+removeContentsRecursive path =+ (`ioeSetLocation` "removeContentsRecursive") `modifyIOError` do+ cont <- getDirectoryContents path+ mapM_ removePathRecursive [path </> x | x <- cont, x /= "." && x /= ".."]+ removeDirectory path+ #if __GLASGOW_HASKELL__ {- |'removeFile' /file/ removes the directory entry for an existing file /file/, where /file/ is not itself a directory. The@@ -637,26 +679,32 @@ -} renameFile :: FilePath -> FilePath -> IO ()-renameFile opath npath = do- -- XXX this test isn't performed atomically with the following rename-#ifdef mingw32_HOST_OS- -- ToDo: use Win32 API- withFileOrSymlinkStatus "renameFile" opath $ \st -> do- is_dir <- isDirectory st-#else- stat <- Posix.getSymbolicLinkStatus opath- let is_dir = Posix.isDirectory stat-#endif- if is_dir- then ioError (ioeSetErrorString- (mkIOError InappropriateType "renameFile" Nothing (Just opath))- "is a directory")- else do+renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do+ -- XXX the tests are not performed atomically with the rename+ checkNotDir opath #ifdef mingw32_HOST_OS Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else Posix.rename opath npath #endif+ -- The underlying rename implementation can throw odd exceptions when the+ -- destination is a directory. For example, Windows typically throws a+ -- permission error, while POSIX systems may throw a resource busy error+ -- if one of the paths refers to the current directory. In these cases,+ -- we check if the destination is a directory and, if so, throw an+ -- InappropriateType error.+ `catchIOError` \ err -> do+ checkNotDir npath+ ioError err+ where checkNotDir path = do+ dirType <- getDirectoryType path+ `catchIOError` \ _ -> return NotDirectory+ case dirType of+ Directory -> errIsDir path+ DirectoryLink -> errIsDir path+ NotDirectory -> return ()+ errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $+ mkIOError InappropriateType "" Nothing (Just path) #endif /* __GLASGOW_HASKELL__ */ @@ -668,7 +716,7 @@ copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath =- copy `catchIOError` (\exc -> throw $ ioeSetLocation exc "copyFile")+ copy `catchIOError` (\exc -> throwIO $ ioeSetLocation exc "copyFile") where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> do allocaBytes bufferSize $ copyContents hFrom hTmp@@ -689,22 +737,29 @@ ignoreIOExceptions io = io `catchIOError` (\_ -> return ()) --- | Given a path referring to a file or directory, returns a--- canonicalized path. The intent is that two paths referring--- to the same file\/directory will map to the same canonicalized--- path.+-- | Canonicalize the path of an existing file or directory. The intent is+-- 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.+-- __Note__: if you only require an absolute path, consider using+-- @'makeAbsolute'@ instead, which is more reliable and does not have+-- unspecified behavior on nonexistent paths. ----- The precise behaviour is that of the C realpath function--- GetFullPathNameW on Windows). In particular, the behaviour--- on paths that do not exist is known to vary from platform--- to platform. Some platforms do not alter the input, some--- do, and on some an exception will be thrown.+-- It is impossible to guarantee that the implication (same file\/dir \<=\>+-- same canonicalized path) holds in either direction: this function can make+-- only a best-effort attempt.+--+-- The precise behaviour is that of the POSIX @realpath@ function (or+-- @GetFullPathNameW@ on Windows). In particular, the behaviour on paths that+-- don't exist can vary from platform to platform. Some platforms do not+-- alter the input, some do, and some throw an exception.+--+-- An empty path is considered to be equivalent to the current directory.+--+-- /Known bug(s)/: on Windows, this function does not resolve symbolic links.+-- canonicalizePath :: FilePath -> IO FilePath+canonicalizePath "" = canonicalizePath "." canonicalizePath fpath = #if defined(mingw32_HOST_OS) do path <- Win32.getFullPathName fpath@@ -713,6 +768,7 @@ GHC.withCString enc fpath $ \pInPath -> allocaBytes long_path_size $ \pOutPath -> do _ <- throwErrnoPathIfNull "canonicalizePath" fpath $ c_realpath pInPath pOutPath+ -- NB: pOutPath will be passed thru as result pointer by c_realpath path <- GHC.peekCString enc pOutPath #endif@@ -726,6 +782,18 @@ -> IO CString #endif +-- | Make a path absolute by prepending the current directory (if it isn't+-- already absolute) and applying @'normalise'@ to the result.+--+-- The operation may fail with the same exceptions as @'getCurrentDirectory'@.+--+-- /Since: 1.2.2.0/+makeAbsolute :: FilePath -> IO FilePath+makeAbsolute = fmap normalise . absolutize+ where absolutize path -- avoid the call to `getCurrentDirectory` if we can+ | isRelative path = fmap (</> path) getCurrentDirectory+ | otherwise = return path+ -- | 'makeRelative' the current directory. makeRelativeToCurrentDirectory :: FilePath -> IO FilePath makeRelativeToCurrentDirectory x = do@@ -758,7 +826,7 @@ -- | Given a file name, searches for the file and returns a list of all -- occurences that are executable. ----- /Since: 1.2.1.0/+-- /Since: 1.2.2.0/ findExecutables :: String -> IO [FilePath] findExecutables binary = do #if defined(mingw32_HOST_OS)@@ -842,13 +910,16 @@ bracket (Posix.openDirStream path) Posix.closeDirStream- loop+ start where- loop dirp = do- e <- Posix.readDirStream dirp- if null e then return [] else do- es <- loop dirp- return (e:es)+ start dirp =+ loop id+ where+ loop acc = do+ e <- Posix.readDirStream dirp+ if null e+ then return (acc [])+ else loop (acc . (e:)) #else bracket (Win32.findFirstFile (path </> "*"))@@ -996,28 +1067,35 @@ * 'isDoesNotExistError' if the file or directory does not exist. -Note: When linked against @unix-2.6.0.0@ or later the reported time-supports sub-second precision if provided by the underlying system-call.-+Note: This function returns a timestamp with sub-second resolution+only if this package is compiled against @unix-2.6.0.0@ or later+for unix systems, and @Win32-2.3.1.0@ or later for windows systems.+Of course this also requires that the underlying file system supports+such high resolution timestamps. -} getModificationTime :: FilePath -> IO UTCTime getModificationTime name = do #ifdef mingw32_HOST_OS- -- ToDo: use Win32 API so we can get sub-second resolution- withFileStatus "getModificationTime" name $ \ st -> do- modificationTime st+#if MIN_VERSION_Win32(2,3,1)+ fad <- Win32.getFileAttributesExStandard name+ let win32_epoch_adjust = 116444736000000000+ Win32.FILETIME ft = Win32.fadLastWriteTime fad+ mod_time = fromIntegral (ft - win32_epoch_adjust) / 10000000 #else+ mod_time <- withFileStatus "getModificationTime" name $ \stat -> do+ mtime <- st_mtime stat+ return $ realToFrac (mtime :: CTime)+#endif+#else stat <- Posix.getFileStatus name- let mod_time :: POSIXTime #if MIN_VERSION_unix(2,6,0)- mod_time = Posix.modificationTimeHiRes stat+ let mod_time = Posix.modificationTimeHiRes stat #else- mod_time = realToFrac $ Posix.modificationTime stat+ let mod_time = realToFrac $ Posix.modificationTime stat #endif- return $ posixSecondsToUTCTime mod_time #endif+ return $ posixSecondsToUTCTime mod_time #endif /* __GLASGOW_HASKELL__ */ @@ -1030,19 +1108,6 @@ 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 ->- withFilePath name $ \s -> do- throwErrnoIfMinus1Retry_ loc (lstat s p)- f p--modificationTime :: Ptr CStat -> IO UTCTime-modificationTime stat = do- mtime <- st_mtime stat- return $ posixSecondsToUTCTime $ realToFrac (mtime :: CTime)- isDirectory :: Ptr CStat -> IO Bool isDirectory stat = do mode <- st_mode stat@@ -1121,7 +1186,7 @@ On Unix, this function returns @$HOME\/.appName@. On Windows, a typical path might be -> C:/Documents And Settings/user/Application Data/appName+> C:/Users/user/AppData/Roaming/appName The operation may fail with: @@ -1206,7 +1271,7 @@ #else getEnv "TMPDIR" `catchIOError` \e -> if isDoesNotExistError e then return "/tmp"- else throw e+ else throwIO e #endif -- ToDo: This should be determined via autoconf (AC_EXEEXT)
changelog.md view
@@ -1,7 +1,39 @@-# Changelog for [`directory` package](http://hackage.haskell.org/package/directory)+Changelog for the [`directory`][1] package+========================================== -## 1.2.1.0 *Mar 2014*+## 1.2.2.0 (Mar 2015) + * Bundled with GHC 7.10.1++ * Make `getModificationTime` support sub-second resolution on Windows++ * Fix silent failure in `createDirectoryIfMissing`++ * Replace `throw` by better defined `throwIO`s++ * [#17](https://github.com/haskell/directory/pull/17):+ Avoid stack overflow in `getDirectoryContents`++ * [#14](https://github.com/haskell/directory/issues/14):+ Expose `findExecutables`++ * [#15](https://github.com/haskell/directory/issues/15):+ `removeDirectoryRecursive` no longer follows symlinks under any+ circumstances++ * [#9](https://github.com/haskell/directory/issues/9):+ Allow trailing path separators in `getPermissions` on Windows++ * [#8](https://github.com/haskell/directory/pull/8):+ `renameFile` now always throws the correct error type+ (`InappropriateType`) when the destination is a directory, as long as the+ filesystem is not being modified concurrently++ * Add `makeAbsolute`, which should be preferred over `canonicalizePath`+ unless one requires symbolic links to be resolved++## 1.2.1.0 (Mar 2014)+ * Bundled with GHC 7.8.1 * Add support for sub-second precision in `getModificationTime` when@@ -19,3 +51,5 @@ * Fix `findExecutable` to check that file permissions indicate executable * New convenience functions `findFiles` and `findFilesWith`++[1]: https://hackage.haskell.org/package/directory
config.guess view
@@ -1,8 +1,8 @@ #! /bin/sh # Attempt to guess a canonical system name.-# Copyright 1992-2013 Free Software Foundation, Inc.+# Copyright 1992-2014 Free Software Foundation, Inc. -timestamp='2013-06-10'+timestamp='2014-03-23' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by@@ -50,7 +50,7 @@ GNU config.guess ($timestamp) Originally written by Per Bothner.-Copyright 1992-2013 Free Software Foundation, Inc.+Copyright 1992-2014 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."@@ -149,7 +149,7 @@ LIBC=gnu #endif EOF- eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC'`+ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^LIBC' | sed 's, ,,g'` ;; esac @@ -826,7 +826,7 @@ *:MINGW*:*) echo ${UNAME_MACHINE}-pc-mingw32 exit ;;- i*:MSYS*:*)+ *:MSYS*:*) echo ${UNAME_MACHINE}-pc-msys exit ;; i*:windows32*:*)@@ -969,10 +969,10 @@ eval `$CC_FOR_BUILD -E $dummy.c 2>/dev/null | grep '^CPU'` test x"${CPU}" != x && { echo "${CPU}-unknown-linux-${LIBC}"; exit; } ;;- or1k:Linux:*:*)- echo ${UNAME_MACHINE}-unknown-linux-${LIBC}+ openrisc*:Linux:*:*)+ echo or1k-unknown-linux-${LIBC} exit ;;- or32:Linux:*:*)+ or32:Linux:*:* | or1k*:Linux:*:*) echo ${UNAME_MACHINE}-unknown-linux-${LIBC} exit ;; padre:Linux:*:*)@@ -1260,16 +1260,26 @@ if test "$UNAME_PROCESSOR" = unknown ; then UNAME_PROCESSOR=powerpc fi- if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then- if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \- (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \- grep IS_64BIT_ARCH >/dev/null- then- case $UNAME_PROCESSOR in- i386) UNAME_PROCESSOR=x86_64 ;;- powerpc) UNAME_PROCESSOR=powerpc64 ;;- esac+ if test `echo "$UNAME_RELEASE" | sed -e 's/\..*//'` -le 10 ; then+ if [ "$CC_FOR_BUILD" != 'no_compiler_found' ]; then+ if (echo '#ifdef __LP64__'; echo IS_64BIT_ARCH; echo '#endif') | \+ (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | \+ grep IS_64BIT_ARCH >/dev/null+ then+ case $UNAME_PROCESSOR in+ i386) UNAME_PROCESSOR=x86_64 ;;+ powerpc) UNAME_PROCESSOR=powerpc64 ;;+ esac+ fi fi+ elif test "$UNAME_PROCESSOR" = i386 ; then+ # Avoid executing cc on OS X 10.9, as it ships with a stub+ # that puts up a graphical alert prompting to install+ # developer tools. Any system running Mac OS X 10.7 or+ # later (Darwin 11 and later) is required to have a 64-bit+ # processor. This is not true of the ARM version of Darwin+ # that Apple uses in portable devices.+ UNAME_PROCESSOR=x86_64 fi echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} exit ;;@@ -1360,154 +1370,6 @@ echo ${UNAME_MACHINE}-unknown-esx exit ;; esac--eval $set_cc_for_build-cat >$dummy.c <<EOF-#ifdef _SEQUENT_-# include <sys/types.h>-# include <sys/utsname.h>-#endif-main ()-{-#if defined (sony)-#if defined (MIPSEB)- /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,- I don't know.... */- printf ("mips-sony-bsd\n"); exit (0);-#else-#include <sys/param.h>- printf ("m68k-sony-newsos%s\n",-#ifdef NEWSOS4- "4"-#else- ""-#endif- ); exit (0);-#endif-#endif--#if defined (__arm) && defined (__acorn) && defined (__unix)- printf ("arm-acorn-riscix\n"); exit (0);-#endif--#if defined (hp300) && !defined (hpux)- printf ("m68k-hp-bsd\n"); exit (0);-#endif--#if defined (NeXT)-#if !defined (__ARCHITECTURE__)-#define __ARCHITECTURE__ "m68k"-#endif- int version;- version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;- if (version < 4)- printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);- else- printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version);- exit (0);-#endif--#if defined (MULTIMAX) || defined (n16)-#if defined (UMAXV)- printf ("ns32k-encore-sysv\n"); exit (0);-#else-#if defined (CMU)- printf ("ns32k-encore-mach\n"); exit (0);-#else- printf ("ns32k-encore-bsd\n"); exit (0);-#endif-#endif-#endif--#if defined (__386BSD__)- printf ("i386-pc-bsd\n"); exit (0);-#endif--#if defined (sequent)-#if defined (i386)- printf ("i386-sequent-dynix\n"); exit (0);-#endif-#if defined (ns32000)- printf ("ns32k-sequent-dynix\n"); exit (0);-#endif-#endif--#if defined (_SEQUENT_)- struct utsname un;-- uname(&un);-- if (strncmp(un.version, "V2", 2) == 0) {- printf ("i386-sequent-ptx2\n"); exit (0);- }- if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */- printf ("i386-sequent-ptx1\n"); exit (0);- }- printf ("i386-sequent-ptx\n"); exit (0);--#endif--#if defined (vax)-# if !defined (ultrix)-# include <sys/param.h>-# if defined (BSD)-# if BSD == 43- printf ("vax-dec-bsd4.3\n"); exit (0);-# else-# if BSD == 199006- printf ("vax-dec-bsd4.3reno\n"); exit (0);-# else- printf ("vax-dec-bsd\n"); exit (0);-# endif-# endif-# else- printf ("vax-dec-bsd\n"); exit (0);-# endif-# else- printf ("vax-dec-ultrix\n"); exit (0);-# endif-#endif--#if defined (alliant) && defined (i860)- printf ("i860-alliant-bsd\n"); exit (0);-#endif-- exit (1);-}-EOF--$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` &&- { echo "$SYSTEM_NAME"; exit; }--# Apollos put the system type in the environment.--test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; }--# Convex versions that predate uname can use getsysinfo(1)--if [ -x /usr/convex/getsysinfo ]-then- case `getsysinfo -f cpu_type` in- c1*)- echo c1-convex-bsd- exit ;;- c2*)- if getsysinfo -f scalar_acc- then echo c32-convex-bsd- else echo c2-convex-bsd- fi- exit ;;- c34*)- echo c34-convex-bsd- exit ;;- c38*)- echo c38-convex-bsd- exit ;;- c4*)- echo c4-convex-bsd- exit ;;- esac-fi cat >&2 <<EOF $0: unable to guess system type
config.sub view
@@ -1,8 +1,8 @@ #! /bin/sh # Configuration validation subroutine script.-# Copyright 1992-2013 Free Software Foundation, Inc.+# Copyright 1992-2014 Free Software Foundation, Inc. -timestamp='2013-08-10'+timestamp='2014-05-01' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by@@ -68,7 +68,7 @@ version="\ GNU config.sub ($timestamp) -Copyright 1992-2013 Free Software Foundation, Inc.+Copyright 1992-2014 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."@@ -265,6 +265,7 @@ | hexagon \ | i370 | i860 | i960 | ia64 \ | ip2k | iq2000 \+ | k1om \ | le32 | le64 \ | lm32 \ | m32c | m32r | m32rle | m68000 | m68k | m88k \@@ -282,8 +283,10 @@ | mips64vr5900 | mips64vr5900el \ | mipsisa32 | mipsisa32el \ | mipsisa32r2 | mipsisa32r2el \+ | mipsisa32r6 | mipsisa32r6el \ | mipsisa64 | mipsisa64el \ | mipsisa64r2 | mipsisa64r2el \+ | mipsisa64r6 | mipsisa64r6el \ | mipsisa64sb1 | mipsisa64sb1el \ | mipsisa64sr71k | mipsisa64sr71kel \ | mipsr5900 | mipsr5900el \@@ -295,8 +298,7 @@ | nds32 | nds32le | nds32be \ | nios | nios2 | nios2eb | nios2el \ | ns16k | ns32k \- | open8 \- | or1k | or32 \+ | open8 | or1k | or1knd | or32 \ | pdp10 | pdp11 | pj | pjl \ | powerpc | powerpc64 | powerpc64le | powerpcle \ | pyramid \@@ -324,7 +326,7 @@ c6x) basic_machine=tic6x-unknown ;;- m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | picochip)+ m6811 | m68hc11 | m6812 | m68hc12 | m68hcs12x | nvptx | picochip) basic_machine=$basic_machine-unknown os=-none ;;@@ -381,6 +383,7 @@ | hexagon-* \ | i*86-* | i860-* | i960-* | ia64-* \ | ip2k-* | iq2000-* \+ | k1om-* \ | le32-* | le64-* \ | lm32-* \ | m32c-* | m32r-* | m32rle-* \@@ -400,8 +403,10 @@ | mips64vr5900-* | mips64vr5900el-* \ | mipsisa32-* | mipsisa32el-* \ | mipsisa32r2-* | mipsisa32r2el-* \+ | mipsisa32r6-* | mipsisa32r6el-* \ | mipsisa64-* | mipsisa64el-* \ | mipsisa64r2-* | mipsisa64r2el-* \+ | mipsisa64r6-* | mipsisa64r6el-* \ | mipsisa64sb1-* | mipsisa64sb1el-* \ | mipsisa64sr71k-* | mipsisa64sr71kel-* \ | mipsr5900-* | mipsr5900el-* \@@ -413,6 +418,7 @@ | nios-* | nios2-* | nios2eb-* | nios2el-* \ | none-* | np1-* | ns16k-* | ns32k-* \ | open8-* \+ | or1k*-* \ | orion-* \ | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* \@@ -1374,7 +1380,7 @@ | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ | -powermax* | -dnix* | -nx6 | -nx7 | -sei* | -dragonfly* \- | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es*)+ | -skyos* | -haiku* | -rdos* | -toppers* | -drops* | -es* | -tirtos*) # Remember, each alternative MUST END IN *, to match a version number. ;; -qnx*)@@ -1590,9 +1596,6 @@ os=-elf ;; mips*-*)- os=-elf- ;;- or1k-*) os=-elf ;; or32-*)
directory.cabal view
@@ -1,17 +1,18 @@ name: directory-version: 1.2.1.0--- GHC 7.6.3 released with 1.2.0.1+version: 1.2.2.0+-- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org-bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=libraries/directory-synopsis: library for directory handling+bug-reports: https://github.com/haskell/directory/issues+synopsis: Platform-agnostic library for filesystem operations description:- This package provides a library for handling directories.+ This library provides a basic set of operations for manipulating files and+ directories in a portable way. category: System build-type: Configure cabal-version: >= 1.10-tested-with: GHC==7.6.3, GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1+tested-with: GHC>=7.4.1 extra-tmp-files: autom4te.cache@@ -21,6 +22,7 @@ extra-source-files: changelog.md+ README.md config.guess config.sub configure@@ -28,15 +30,27 @@ directory.buildinfo include/HsDirectoryConfig.h.in install-sh+ tests/*.hs+ tests/*.stderr+ tests/*.stdout+ tests/Makefile+ tests/all.T+ tests/copyFile001dir/source+ tests/copyFile002dir/source+ tests/createDirectory001.stdout-mingw32+ tests/createDirectoryIfMissing001.stdout-mingw32+ tests/getDirContents002.stderr-mingw32+ tests/getPermissions001.stdout-alpha-dec-osf3+ tests/getPermissions001.stdout-i386-unknown-freebsd+ tests/getPermissions001.stdout-i386-unknown-openbsd+ tests/getPermissions001.stdout-mingw+ tests/getPermissions001.stdout-x86_64-unknown-openbsd+ tools/ghc.patch+ tools/run-tests source-repository head type: git- location: http://git.haskell.org/packages/directory.git--source-repository this- type: git- location: http://git.haskell.org/packages/directory.git- tag: directory-1.2.0.2-release+ location: https://github.com/haskell/directory Library default-language: Haskell2010@@ -57,12 +71,21 @@ HsDirectory.h build-depends:- base >= 4.5 && < 4.8,- time >= 1.4 && < 1.5,- filepath >= 1.3 && < 1.4+ base >= 4.5 && < 4.9,+ time >= 1.4 && < 1.6,+ filepath >= 1.3 && < 1.5 if os(windows) build-depends: Win32 >= 2.2.2 && < 2.4 else build-depends: unix >= 2.5.1 && < 2.8 ghc-options: -Wall++test-suite test+ default-language: Haskell2010+ other-extensions: CPP ForeignFunctionInterface+ ghc-options: -Wall+ hs-source-dirs: tools+ main-is: dispatch-tests.hs+ type: exitcode-stdio-1.0+ build-depends: base, directory
+ tests/Makefile view
@@ -0,0 +1,7 @@+# This Makefile runs the tests using GHC's testsuite framework. It+# assumes the package is part of a GHC build tree with the testsuite+# installed in ../../../testsuite.++TOP=../../../testsuite+include $(TOP)/mk/boilerplate.mk+include $(TOP)/mk/test.mk
+ tests/T8482.hs view
@@ -0,0 +1,16 @@+import System.Directory+import Control.Exception++tmp1 = "T8482.tmp1"+testdir = "T8482.dir"++main = do+ writeFile tmp1 "hello"+ createDirectory testdir+ tryRenameFile testdir tmp1 >>= print -- InappropriateType+ tryRenameFile tmp1 testdir >>= print -- InappropriateType+ tryRenameFile tmp1 "." >>= print -- InappropriateType+ removeDirectory testdir+ removeFile tmp1+ where tryRenameFile :: FilePath -> FilePath -> IO (Either IOException ())+ tryRenameFile opath npath = try $ renameFile opath npath
+ tests/T8482.stdout view
@@ -0,0 +1,3 @@+Left T8482.dir: renameFile: inappropriate type (is a directory)+Left T8482.dir: renameFile: inappropriate type (is a directory)+Left .: renameFile: inappropriate type (is a directory)
+ tests/TestUtils.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module TestUtils+ ( copyPathRecursive+ , createSymbolicLink+ , modifyPermissions+ , tryCreateSymbolicLink+ ) where+import System.Directory+import System.FilePath ((</>))+import System.IO.Error (ioeSetLocation, modifyIOError)+#ifdef mingw32_HOST_OS+import Foreign (Ptr)+import Foreign.C (CUChar(..), CULong(..), CWchar(..), withCWString)+import System.FilePath (takeDirectory)+import System.IO (hPutStrLn, stderr)+import System.IO.Error (catchIOError, ioeSetErrorString, isPermissionError,+ mkIOError, permissionErrorType)+import System.Win32.Types (failWith, getLastError)+#else+import System.Posix.Files (createSymbolicLink)+#endif++#ifdef mingw32_HOST_OS+# if defined i386_HOST_ARCH+# define WINAPI stdcall+# elif defined x86_64_HOST_ARCH+# define WINAPI ccall+# else+# error unknown architecture+# endif+foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"+ c_CreateSymbolicLink :: Ptr CWchar -> Ptr CWchar -> CULong -> IO CUChar+#endif++-- | @'copyPathRecursive' path@ copies an existing file or directory at+-- /path/ together with its contents and subdirectories.+--+-- Warning: mostly untested and might not handle symlinks correctly.+copyPathRecursive :: FilePath -> FilePath -> IO ()+copyPathRecursive source dest =+ (`ioeSetLocation` "copyPathRecursive") `modifyIOError` do+ dirExists <- doesDirectoryExist source+ if dirExists+ then do+ contents <- getDirectoryContents source+ createDirectory dest+ mapM_ (uncurry copyPathRecursive)+ [(source </> x, dest </> x) | x <- contents, x /= "." && x /= ".."]+ else copyFile source dest++modifyPermissions :: FilePath -> (Permissions -> Permissions) -> IO ()+modifyPermissions path modify = do+ permissions <- getPermissions path+ setPermissions path (modify permissions)++#if mingw32_HOST_OS+createSymbolicLink :: String -> String -> IO ()+createSymbolicLink target link =+ (`ioeSetLocation` "createSymbolicLink") `modifyIOError` do+ isDir <- (fromIntegral . fromEnum) `fmap`+ doesDirectoryExist (takeDirectory link </> target)+ withCWString target $ \ target' ->+ withCWString link $ \ link' -> do+ status <- c_CreateSymbolicLink link' target' isDir+ if status == 0+ then do+ errCode <- getLastError+ if errCode == c_ERROR_PRIVILEGE_NOT_HELD+ then ioError . (`ioeSetErrorString` permissionErrorMsg) $+ mkIOError permissionErrorType "" Nothing (Just link)+ else failWith "createSymbolicLink" errCode+ else return ()+ where c_ERROR_PRIVILEGE_NOT_HELD = 0x522+ permissionErrorMsg = "no permission to create symbolic links"+#endif++-- | Attempt to create a symbolic link. On Windows, this falls back to+-- copying if forbidden due to Group Policies.+tryCreateSymbolicLink :: FilePath -> FilePath -> IO ()+tryCreateSymbolicLink target link = createSymbolicLink target link+#ifdef mingw32_HOST_OS+ `catchIOError` \ e ->+ if isPermissionError e+ then copyPathRecursive (takeDirectory link </> target) link+ else ioError e+#endif
+ tests/all.T view
@@ -0,0 +1,32 @@+test('canonicalizePath001', normal, compile_and_run, [''])+test('currentDirectory001', normal, compile_and_run, [''])+test('directory001', normal, compile_and_run, [''])+test('doesDirectoryExist001', normal, compile_and_run, [''])++# This test is a bit bogus. Disable for GHCi.+test('getDirContents001', omit_ways(['ghci']), compile_and_run, ['-fno-gen-manifest'])++test('getDirContents002', [ normalise_exe, exit_code(1) ],+ compile_and_run, [''])++# Depends on binary from previous run, which gets removed by the driver way=ghci+test('getPermissions001', omit_ways(['ghci']), compile_and_run, ['-cpp'])++test('copyFile001', extra_clean(['copyFile001dir/target']),+ compile_and_run, [''])+test('copyFile002', extra_clean(['copyFile002dir/target']),+ compile_and_run, [''])++test('renameFile001', extra_clean(['renameFile001.tmp1','renameFile001.tmp2']),+ compile_and_run, [''])++test('createDirectory001', normal, compile_and_run, [''])++test('createDirectoryIfMissing001', normal, compile_and_run, [''])++# No sane way to tell whether the output is reasonable here...+test('getHomeDirectory001', ignore_output, compile_and_run, [''])++test('T8482', normal, compile_and_run, [''])++test('removeDirectoryRecursive001', normal, compile_and_run, [''])
+ tests/canonicalizePath001.hs view
@@ -0,0 +1,8 @@+module Main (main) where+import System.Directory+import System.IO.Error (catchIOError)++main = do+ dot <- canonicalizePath "."+ nul <- canonicalizePath "" `catchIOError` \ _ -> return ""+ print (dot == nul)
+ tests/canonicalizePath001.stdout view
@@ -0,0 +1,1 @@+True
+ tests/copyFile001.hs view
@@ -0,0 +1,26 @@++module Main (main) where++import Control.Exception+import Data.List+import System.Directory+import System.IO++main :: IO ()+main = do tryIO $ removeFile to+ cs_before <- getDirectoryContents "copyFile001dir"+ putStrLn "Before:"+ print $ sort cs_before+ copyFile from to+ cs_before <- getDirectoryContents "copyFile001dir"+ putStrLn "After:"+ print $ sort cs_before+ readFile to >>= print++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++from, to :: FilePath+from = "copyFile001dir/source"+to = "copyFile001dir/target"+
+ tests/copyFile001.stdout view
@@ -0,0 +1,5 @@+Before:+[".","..","source"]+After:+[".","..","source","target"]+"This is the data"
+ tests/copyFile001dir/source view
@@ -0,0 +1,1 @@+This is the data
+ tests/copyFile002.hs view
@@ -0,0 +1,31 @@++module Main (main) where++import Control.Exception+import Data.List+import System.Directory+import System.IO++-- like copyFile001, but moves a file in the current directory+-- See bug #1652+main :: IO ()+main = do d <- getCurrentDirectory+ flip finally (setCurrentDirectory d) $ do+ setCurrentDirectory "copyFile002dir"+ tryIO $ removeFile to+ cs_before <- getDirectoryContents "."+ putStrLn "Before:"+ print $ sort cs_before+ copyFile from to+ cs_before <- getDirectoryContents "."+ putStrLn "After:"+ print $ sort cs_before+ readFile to >>= print++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++from, to :: FilePath+from = "source"+to = "target"+
+ tests/copyFile002.stdout view
@@ -0,0 +1,5 @@+Before:+[".","..","source"]+After:+[".","..","source","target"]+"This is the data"
+ tests/copyFile002dir/source view
@@ -0,0 +1,1 @@+This is the data
+ tests/createDirectory001.hs view
@@ -0,0 +1,12 @@+import System.Directory +import Control.Exception + +testdir = "createDirectory001.dir" + +main = do + try (removeDirectory testdir) :: IO (Either IOException ()) + createDirectory testdir + r <- try $ createDirectory testdir + print (r :: Either IOException ()) -- already exists + removeDirectory testdir +
+ tests/createDirectory001.stdout view
@@ -0,0 +1,1 @@+Left createDirectory001.dir: createDirectory: already exists (File exists)
+ tests/createDirectory001.stdout-mingw32 view
@@ -0,0 +1,1 @@+Left CreateDirectory "createDirectory001.dir": already exists (Cannot create a file when that file already exists.)
+ tests/createDirectoryIfMissing001.hs view
@@ -0,0 +1,79 @@+module Main(main) where++import Control.Concurrent+import Control.Monad+import Control.Exception as E+import System.Directory+import System.FilePath+import System.IO.Error++testdir = "createDirectoryIfMissing001.d"+testdir_a = testdir </> "a"++main = do+ cleanup++ report $ createDirectoryIfMissing False testdir+ cleanup++ report $ createDirectoryIfMissing False testdir_a+ -- should fail with does not exist++ report $ createDirectoryIfMissing True testdir_a+ -- should succeed with no error+ report $ createDirectoryIfMissing False testdir_a+ -- should succeed with no error+ report $ createDirectoryIfMissing False (addTrailingPathSeparator testdir_a)+ -- should succeed with no error++ cleanup+ report $ createDirectoryIfMissing True (addTrailingPathSeparator testdir_a)++ -- look for race conditions: #2808. This fails with+ -- +RTS -N2 and directory 1.0.0.2.+ m <- newEmptyMVar+ forkIO $ do replicateM_ 10000 create; putMVar m ()+ forkIO $ do replicateM_ 10000 cleanup; putMVar m ()+ replicateM_ 2 $ takeMVar m++-- This test fails on Windows; see #2924+-- replicateM_ 2 $ +-- forkIO $ do replicateM_ 5000 (do create; cleanup); putMVar m ()+-- replicateM_ 2 $ takeMVar m++ cleanup++ -- these are all supposed to fail++ writeFile testdir testdir+ report $ createDirectoryIfMissing False testdir+ removeFile testdir+ cleanup++ writeFile testdir testdir+ report $ createDirectoryIfMissing True testdir_a+ removeFile testdir+ cleanup++-- createDirectoryIfMissing is allowed to fail with isDoesNotExistError if+-- another process/thread removes one of the directories during the proces+-- of creating the hierarchy.+--+-- It is also allowed to fail with permission errors (see #2924)+create = tryJust (guard . (\e -> isDoesNotExistError e || isPermissionError e)) $ createDirectoryIfMissing True testdir_a++cleanup = ignore $ removeDirectoryRecursive testdir++report :: Show a => IO a -> IO ()+report io = do+ r <- E.try io+ case r of+ Left e -> print (e :: SomeException)+ Right a -> print a++ignore :: IO a -> IO ()+ignore io = do+ r <- E.try io+ case r of+ Left e -> let _ = e :: SomeException in return ()+ Right a -> return ()
+ tests/createDirectoryIfMissing001.stdout view
@@ -0,0 +1,8 @@+()+createDirectoryIfMissing001.d/a: createDirectory: does not exist (No such file or directory)+()+()+()+()+createDirectoryIfMissing001.d: createDirectory: already exists (File exists)+createDirectoryIfMissing001.d/a: createDirectory: inappropriate type (Not a directory)
+ tests/createDirectoryIfMissing001.stdout-mingw32 view
@@ -0,0 +1,8 @@+()+CreateDirectory "createDirectoryIfMissing001.d\\a": does not exist (The system cannot find the path specified.)+()+()+()+()+CreateDirectory "createDirectoryIfMissing001.d": already exists (Cannot create a file when that file already exists.)+CreateDirectory "createDirectoryIfMissing001.d": already exists (Cannot create a file when that file already exists.)
+ tests/currentDirectory001.hs view
@@ -0,0 +1,27 @@++import System.Directory (getCurrentDirectory, setCurrentDirectory,+ createDirectory, removeDirectory,+ getDirectoryContents)++main :: IO ()+main = do+ oldpwd <- getCurrentDirectory+ createDirectory dir+ setCurrentDirectory dir+ ~[n1, n2] <- getDirectoryContents "."+ if dot n1 && dot n2 + then do+ setCurrentDirectory oldpwd+ removeDirectory dir+ putStr "Okay\n"+ else+ ioError (userError "Oops")++dot :: String -> Bool+dot "." = True+dot ".." = True+dot _ = False++dir :: FilePath+dir = "currentDirectory001-dir"+
+ tests/currentDirectory001.stdout view
@@ -0,0 +1,1 @@+Okay
+ tests/directory001.hs view
@@ -0,0 +1,16 @@+import System.IO+import System.Directory++main = do+ createDirectory "foo"+ h <- openFile "foo/bar" WriteMode+ hPutStr h "Okay\n"+ hClose h+ renameFile "foo/bar" "foo/baz"+ renameDirectory "foo" "bar"+ h <- openFile "bar/baz" ReadMode+ stuff <- hGetContents h+ putStr stuff+-- hClose h -- an error !+ removeFile "bar/baz"+ removeDirectory "bar"
+ tests/directory001.stdout view
@@ -0,0 +1,1 @@+Okay
+ tests/doesDirectoryExist001.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE CPP #-}+-- !!! "/" was not recognised as a directory in 6.0.x+import System.Directory++#ifdef mingw32_HOST_OS+root = "C:\\"+#else+root = "/"+#endif++main = doesDirectoryExist root >>= print
+ tests/doesDirectoryExist001.stdout view
@@ -0,0 +1,1 @@+True
+ tests/getDirContents001.hs view
@@ -0,0 +1,18 @@+import System.Directory+import Control.Exception+import System.FilePath+import Data.List++dir = "getDirContents001.dir"++main = do+ try cleanup :: IO (Either IOException ())+ bracket (createDirectory dir) (const cleanup) $ \_ -> do+ getDirectoryContents dir >>= print . sort+ mapM_ (\s -> writeFile (dir </> ('f':show s)) (show s)) [1..100]+ getDirectoryContents dir >>= print . sort++cleanup = do+ files <- getDirectoryContents dir+ mapM_ (removeFile . (dir </>)) (filter (not . ("." `isPrefixOf`)) files)+ removeDirectory dir
+ tests/getDirContents001.stdout view
@@ -0,0 +1,2 @@+[".",".."]+[".","..","f1","f10","f100","f11","f12","f13","f14","f15","f16","f17","f18","f19","f2","f20","f21","f22","f23","f24","f25","f26","f27","f28","f29","f3","f30","f31","f32","f33","f34","f35","f36","f37","f38","f39","f4","f40","f41","f42","f43","f44","f45","f46","f47","f48","f49","f5","f50","f51","f52","f53","f54","f55","f56","f57","f58","f59","f6","f60","f61","f62","f63","f64","f65","f66","f67","f68","f69","f7","f70","f71","f72","f73","f74","f75","f76","f77","f78","f79","f8","f80","f81","f82","f83","f84","f85","f86","f87","f88","f89","f9","f90","f91","f92","f93","f94","f95","f96","f97","f98","f99"]
+ tests/getDirContents002.hs view
@@ -0,0 +1,3 @@+import System.Directory + +main = getDirectoryContents "nonexistent"
+ tests/getDirContents002.stderr view
@@ -0,0 +1,1 @@+getDirContents002: nonexistent: getDirectoryContents: does not exist (No such file or directory)
+ tests/getDirContents002.stderr-mingw32 view
@@ -0,0 +1,1 @@+getDirContents002.exe: nonexistent: getDirectoryContents: does not exist (The system cannot find the path specified.)
+ tests/getHomeDirectory001.hs view
@@ -0,0 +1,8 @@+import System.Directory + +main = do + getHomeDirectory >>= print + getAppUserDataDirectory "test" >>= print + getUserDocumentsDirectory >>= print + getTemporaryDirectory >>= print + return ()
+ tests/getPermissions001.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+import System.Directory++main = do+#ifdef mingw32_HOST_OS+ let exe = ".exe"+#else+ let exe = ""+#endif+ p <- getPermissions "."+ print p+ p <- getPermissions "getPermissions001.hs"+ print p+ p <- getPermissions ("getPermissions001" ++ exe)+ print p++ -- issue #9: Windows doesn't like trailing path separators+ _ <- getPermissions "../tests/"++ return ()
+ tests/getPermissions001.stdout view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = False, searchable = True}+Permissions {readable = True, writable = True, executable = False, searchable = False}+Permissions {readable = True, writable = True, executable = True, searchable = False}
+ tests/getPermissions001.stdout-alpha-dec-osf3 view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = False, searchable = True}+Permissions {readable = True, writable = True, executable = False, searchable = False}+Permissions {readable = True, writable = False, executable = True, searchable = False}
+ tests/getPermissions001.stdout-i386-unknown-freebsd view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = False, searchable = True}+Permissions {readable = True, writable = True, executable = False, searchable = False}+Permissions {readable = True, writable = False, executable = True, searchable = False}
+ tests/getPermissions001.stdout-i386-unknown-openbsd view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = False, searchable = True}+Permissions {readable = True, writable = True, executable = False, searchable = False}+Permissions {readable = True, writable = False, executable = True, searchable = False}
+ tests/getPermissions001.stdout-mingw view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = True, searchable = True}+Permissions {readable = True, writable = True, executable = True, searchable = True}+Permissions {readable = True, writable = True, executable = True, searchable = True}
+ tests/getPermissions001.stdout-x86_64-unknown-openbsd view
@@ -0,0 +1,3 @@+Permissions {readable = True, writable = True, executable = False, searchable = True}+Permissions {readable = True, writable = True, executable = False, searchable = False}+Permissions {readable = True, writable = False, executable = True, searchable = False}
+ tests/removeDirectoryRecursive001.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+module Main (main) where+import Data.List (sort)+import System.Directory+import System.FilePath ((</>), normalise)+import System.IO.Error (catchIOError)+import TestUtils++testName :: String+testName = "removeDirectoryRecursive001"++tmpD :: String+tmpD = testName ++ ".tmp"++tmp :: String -> String+tmp s = tmpD </> normalise s++main :: IO ()+main = do++ ------------------------------------------------------------+ -- clean up junk from previous invocations++ modifyPermissions (tmp "c") (\ p -> p { writable = True })+ `catchIOError` \ _ -> return ()+ removeDirectoryRecursive tmpD+ `catchIOError` \ _ -> return ()++ ------------------------------------------------------------+ -- set up++ createDirectoryIfMissing True (tmp "a/x/w")+ createDirectoryIfMissing True (tmp "a/y")+ createDirectoryIfMissing True (tmp "a/z")+ createDirectoryIfMissing True (tmp "b")+ createDirectoryIfMissing True (tmp "c")+ writeFile (tmp "a/x/w/u") "foo"+ writeFile (tmp "a/t") "bar"+ tryCreateSymbolicLink (normalise "../a") (tmp "b/g")+ tryCreateSymbolicLink (normalise "../b") (tmp "c/h")+ tryCreateSymbolicLink (normalise "a") (tmp "d")+ modifyPermissions (tmp "c") (\ p -> p { writable = False })++ ------------------------------------------------------------+ -- tests++ getDirectoryContents tmpD >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "d") >>= putStrLn . unwords . sort++ putStrLn ""++ removeDirectoryRecursive (tmp "d")+ `catchIOError` \ _ -> removeFile (tmp "d")+#ifdef mingw32_HOST_OS+ `catchIOError` \ _ -> removeDirectory (tmp "d")+#endif++ getDirectoryContents tmpD >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "c") >>= putStrLn . unwords . sort++ putStrLn ""++ removeDirectoryRecursive (tmp "c")+ `catchIOError` \ _ -> do+ modifyPermissions (tmp "c") (\ p -> p { writable = True })+ removeDirectoryRecursive (tmp "c")++ getDirectoryContents tmpD >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "b") >>= putStrLn . unwords . sort++ putStrLn ""++ removeDirectoryRecursive (tmp "b")++ getDirectoryContents tmpD >>= putStrLn . unwords . sort+ getDirectoryContents (tmp "a") >>= putStrLn . unwords . sort++ putStrLn ""++ removeDirectoryRecursive (tmp "a")++ getDirectoryContents tmpD >>= putStrLn . unwords . sort++ ------------------------------------------------------------+ -- clean up++ removeDirectoryRecursive tmpD
+ tests/removeDirectoryRecursive001.stdout view
@@ -0,0 +1,19 @@+. .. a b c d+. .. t x y z+. .. g+. .. h+. .. t x y z++. .. a b c+. .. t x y z+. .. g+. .. h++. .. a b+. .. t x y z+. .. g++. .. a+. .. t x y z++. ..
+ tests/renameFile001.hs view
@@ -0,0 +1,13 @@+import System.Directory + +tmp1 = "renameFile001.tmp1" +tmp2 = "renameFile001.tmp2" + +main = do + writeFile tmp1 "test" + renameFile tmp1 tmp2 + readFile tmp2 >>= print + writeFile tmp1 "test2" + renameFile tmp2 tmp1 + readFile tmp1 >>= print +
+ tests/renameFile001.stdout view
@@ -0,0 +1,2 @@+"test"+"test"
+ tools/dispatch-tests.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Main (main) where+import Foreign (Ptr)+import Foreign.C (CChar(..), CInt(..), withCString)+import Data.Functor ((<$>))+import System.Directory () -- to make sure `directory` is built beforehand+import System.Environment (getArgs)+import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)++main :: IO ()+main = do++ -- check if 'cabal exec' is supported (didn't exist until 1.20)+ cabalExecTest <- rawSystem "sh" ["-c", "cabal >/dev/null 2>&1 exec true"]++ -- execute in the Cabal sandbox environment if possible+ let prefix = case cabalExecTest of+ ExitSuccess -> ["cabal", "exec", "--"]+ ExitFailure _ -> []++ args <- getArgs+ let command : arguments = prefix ++ ["sh", "tools/run-tests"] ++ args+ exitWith =<< normalizeExitCode <$> rawSystem command arguments++makeExitCode :: Int -> ExitCode+makeExitCode 0 = ExitSuccess+makeExitCode e = ExitFailure e++-- on Linux the exit code is right-shifted by 8 bits, causing exit codes to be+-- rather large; older versions of GHC don't seem to handle that well in+-- `exitWith`+normalizeExitCode :: ExitCode -> ExitCode+normalizeExitCode ExitSuccess = ExitSuccess+normalizeExitCode (ExitFailure _) = ExitFailure 1++-- we can't use the `process` library as it causes a dependency cycle with+-- Cabal, so we reinvent the wheel here in a simplistic way; this will+-- probably break with non-ASCII characters on Windows+rawSystem :: String -> [String] -> IO ExitCode+rawSystem cmd args =+ withCString (quoteCmdArgs (cmd : args)) $ \ c_command ->+ makeExitCode . fromIntegral <$> c_system c_command++-- handle the different quoting rules in CMD.EXE vs POSIX shells+quoteCmdArgs :: [String] -> String+quoteCmdArgs cmdArgs =+#ifdef mingw32_HOST_OS+ -- the arcane quoting rules require us to add an extra set of quotes+ -- around the entire thing: see `help cmd` or look at+ -- https://superuser.com/a/238813+ "\"" ++ unwords (quote <$> cmdArgs) ++ "\""+ where quote s = "\"" ++ replaceElem '"' "\"\"" s ++ "\""+#else+ unwords (quote <$> cmdArgs)+ where quote s = "'" ++ replaceElem '\'' "'\\''" s ++ "'"+#endif++replaceElem :: Eq a => a -> [a] -> [a] -> [a]+replaceElem match repl = concat . (replace <$>)+ where replace c | c == match = repl+ | otherwise = [c]++foreign import ccall safe "stdlib.h system" c_system :: Ptr CChar -> IO CInt
+ tools/ghc.patch view
@@ -0,0 +1,62 @@+# allow ghc and its tools to be located in different directories+--- testsuite/mk/boilerplate.mk++++ testsuite/mk/boilerplate.mk+@@ -56,6 +56,7 @@ TEST_HC := $(STAGE2_GHC)+ endif+ + else++implicit_compiler = YES+ IN_TREE_COMPILER = NO+ TEST_HC := $(shell which ghc)+ endif+@@ -87,24 +88,30 @@ endif+ # containing spaces+ BIN_ROOT = $(shell dirname '$(TEST_HC)')+ ++ifeq "$(implicit_compiler)" "YES"++find_tool = $(shell which $(1))++else++find_tool = $(BIN_ROOT)/$(1)++endif+++ ifeq "$(GHC_PKG)" ""+-GHC_PKG := $(BIN_ROOT)/ghc-pkg++GHC_PKG := $(call find_tool,ghc-pkg)+ endif+ + ifeq "$(RUNGHC)" ""+-RUNGHC := $(BIN_ROOT)/runghc++RUNGHC := $(call find_tool,runghc)+ endif+ + ifeq "$(HSC2HS)" ""+-HSC2HS := $(BIN_ROOT)/hsc2hs++HSC2HS := $(call find_tool,hsc2hs)+ endif+ + ifeq "$(HP2PS_ABS)" ""+-HP2PS_ABS := $(BIN_ROOT)/hp2ps++HP2PS_ABS := $(call find_tool,hp2ps)+ endif+ + ifeq "$(HPC)" ""+-HPC := $(BIN_ROOT)/hpc++HPC := $(call find_tool,hpc)+ endif+ + $(eval $(call canonicaliseExecutable,TEST_HC))++# 'die' is not available until GHC 7.10+--- testsuite/timeout/timeout.hs++++ testsuite/timeout/timeout.hs+@@ -30,8 +30,8 @@ main = do+ [secs,cmd] ->+ case reads secs of+ [(secs', "")] -> run secs' cmd+- _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")+- _ -> die ("Bad arguments " ++ show args)++ _ -> ((>> exitFailure) . hPutStrLn stderr) ("Can't parse " ++ show secs ++ " as a number of seconds")++ _ -> ((>> exitFailure) . hPutStrLn stderr) ("Bad arguments " ++ show args)+ + timeoutMsg :: String+ timeoutMsg = "Timeout happened...killing process..."
+ tools/run-tests view
@@ -0,0 +1,50 @@+#!/bin/sh+# run all of the tests under the `tests` directory using the GHC test+# framework; for more info about this framework, see:+# https://ghc.haskell.org/trac/ghc/wiki/Building/RunningTests+#+# arguments received by this script are passed as arguments to the `make`+# invocation that initiates the tests+set -e++# check if `-package-db` is supported (didn't exist until 1.20)+# note that we don't use `-package-db` directly because older versions will+# interpret it as `-package -db`+if ghc 2>&1 -no-user-package-db |+ grep >/dev/null 2>&1 "ghc: unrecognised flags: -no-user-package-db"+then db=conf+else db=db+fi++[ -z "$HSFLAGS" ] || HSFLAGS=\ $HSFLAGS+HSFLAGS="-package-$db ../dist/package.conf.inplace$HSFLAGS"+HSFLAGS="-optP-include -optP../dist/build/autogen/cabal_macros.h $HSFLAGS"+export HSFLAGS++# download the GHC repository+[ -f dist/testsuite/ghc.ok ] || {+ rm -fr dist/testsuite/ghc+ git clone --depth 1 https://github.com/ghc/ghc dist/testsuite/ghc+ patch <tools/ghc.patch -d dist/testsuite/ghc -N -p 0 -r - || :+ touch dist/testsuite/ghc.ok+}++# we can't just specify `TOP` as an argument for `make` because it will+# override `TOP` for *every* included makefile+sed >dist/testsuite/Makefile \+ "s|^TOP=.*$|TOP=../dist/testsuite/ghc/testsuite|" \+ tests/Makefile++cd tests+make -f ../dist/testsuite/Makefile WAY=normal EXTRA_HC_OPTS="$HSFLAGS" "$@" |+ tee ../dist/testsuite/test.out++# since the test framework doesn't report an exit status, we need to manually+# find out whether the test had any failures>+{+ grep '^ *0 had missing libraries$' ../dist/testsuite/test.out+ grep '^ *0 caused framework failures$' ../dist/testsuite/test.out+ grep '^ *0 unexpected passes$' ../dist/testsuite/test.out+ grep '^ *0 unexpected failures$' ../dist/testsuite/test.out+ grep '^ *0 unexpected stat failures$' ../dist/testsuite/test.out+} >/dev/null 2>/dev/null