[commit: packages/directory] master: Implement `withCurrentDirectory` (497c555)
git at git.haskell.org
git at git.haskell.org
Fri Dec 18 09:51:58 UTC 2015
Repository : ssh://git@git.haskell.org/directory
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/497c55508fc2d7ebf5dedb726d0692837ccff0ce/directory
>---------------------------------------------------------------
commit 497c55508fc2d7ebf5dedb726d0692837ccff0ce
Author: Mateusz Kowalczyk <fuuzetsu at fuuzetsu.co.uk>
Date: Thu Jun 11 22:29:46 2015 +0100
Implement `withCurrentDirectory`
This function allows us to perform an IO action in a different directory
without the hassle of manually switching and restoring the directory.
>---------------------------------------------------------------
497c55508fc2d7ebf5dedb726d0692837ccff0ce
System/Directory.hs | 15 +++++++++++++++
changelog.md | 2 ++
tests/Main.hs | 2 ++
tests/WithCurrentDirectory.hs | 26 ++++++++++++++++++++++++++
4 files changed, 45 insertions(+)
diff --git a/System/Directory.hs b/System/Directory.hs
index 3fe8406..84895f5 100644
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -28,6 +28,7 @@ module System.Directory
, getDirectoryContents
, getCurrentDirectory
, setCurrentDirectory
+ , withCurrentDirectory
-- * Pre-defined directories
, getHomeDirectory
@@ -1098,6 +1099,20 @@ setCurrentDirectory path =
Posix.changeWorkingDirectory path
#endif
+-- | Run a given 'IO' action inside the specified directory while
+-- preserving the directory we were in at the start.
+--
+-- This function can fail with the same exceptions that
+-- 'getCurrentDirectory' and 'setCurrentDirectory' can.
+--
+-- @since 1.2.3.0
+withCurrentDirectory :: FilePath -- ^ The path of the directory to execute in
+ -> IO a -- ^ The action to execute
+ -> IO a
+withCurrentDirectory dir action =
+ bracket getCurrentDirectory setCurrentDirectory $ \_ ->
+ setCurrentDirectory dir >> action
+
{- |The operation 'doesDirectoryExist' returns 'True' if the argument file
exists and is either a directory or a symbolic link to a directory,
and 'False' otherwise.
diff --git a/changelog.md b/changelog.md
index 1d886f9..fd8079e 100644
--- a/changelog.md
+++ b/changelog.md
@@ -21,6 +21,8 @@ Changelog for the [`directory`][1] package
* Deprecate use of `HsDirectory.h` and `HsDirectoryConfig.h`
+ * Implement `withCurrentDirectory`
+
## 1.2.2.1 (Apr 2015)
* Fix dependency problem on NixOS when building with tests
diff --git a/tests/Main.hs b/tests/Main.hs
index 5ce8480..b5340ff 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -16,6 +16,7 @@ import qualified GetPermissions001
import qualified RemoveDirectoryRecursive001
import qualified RenameFile001
import qualified T8482
+import qualified WithCurrentDirectory
main :: IO ()
main = T.testMain $ \ _t -> do
@@ -35,3 +36,4 @@ main = T.testMain $ \ _t -> do
T.isolatedRun _t "RemoveDirectoryRecursive001" RemoveDirectoryRecursive001.main
T.isolatedRun _t "RenameFile001" RenameFile001.main
T.isolatedRun _t "T8482" T8482.main
+ T.isolatedRun _t "WithCurrentDirectory" WithCurrentDirectory.main
diff --git a/tests/WithCurrentDirectory.hs b/tests/WithCurrentDirectory.hs
new file mode 100644
index 0000000..520c363
--- /dev/null
+++ b/tests/WithCurrentDirectory.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE CPP #-}
+module WithCurrentDirectory where
+#include "util.inl"
+import Data.Monoid ((<>))
+import Data.List (sort)
+import System.Directory
+import System.FilePath ((</>))
+
+main :: TestEnv -> IO ()
+main _t = do
+ createDirectory dir
+ -- Make sure we're starting empty
+ T(expectEq) () specials . sort =<< getDirectoryContents dir
+ cwd <- getCurrentDirectory
+ withCurrentDirectory dir (writeFile testfile contents)
+ -- Are we still in original directory?
+ T(expectEq) () cwd =<< getCurrentDirectory
+ -- Did the test file get created?
+ T(expectEq) () (specials <> [testfile]) . sort =<< getDirectoryContents dir
+ -- Does the file contain what we expected to write?
+ T(expectEq) () contents =<< readFile (dir </> testfile)
+ where
+ testfile = "testfile"
+ contents = "some data\n"
+ dir = "dir"
+ specials = [".", ".."]
More information about the ghc-commits
mailing list