Skip to content

Commit 6aa2c4a

Browse files
mgsloanmgsloan
committed
Add functions to Path.IO + use these utils more
1 parent 7e6a8af commit 6aa2c4a

15 files changed

Lines changed: 146 additions & 171 deletions

File tree

‎src/Path/IO.hs‎

Lines changed: 80 additions & 88 deletions
Original file line numberDiff line numberDiff line change
@@ -10,15 +10,22 @@ module Path.IO
1010
,resolveDirMaybe
1111
,resolveFileMaybe
1212
,ResolveException(..)
13+
,removeFile
1314
,removeFileIfExists
1415
,removeTree
1516
,removeTreeIfExists
16-
,fileExists
17+
,renameFile
1718
,renameFileIfExists
19+
,renameDir
1820
,renameDirIfExists
21+
,moveFile
1922
,moveFileIfExists
23+
,moveDir
2024
,moveDirIfExists
25+
,fileExists
2126
,dirExists
27+
,copyFile
28+
,copyFileIfExists
2229
,copyDirectoryRecursive
2330
,createTree)
2431
where
@@ -31,7 +38,7 @@ import Data.Either
3138
import Data.Maybe
3239
import Data.Typeable
3340
import Path
34-
import System.Directory
41+
import qualified System.Directory as D
3542
import qualified System.FilePath as FP
3643
import System.IO.Error
3744

@@ -47,7 +54,7 @@ instance Show ResolveException where
4754

4855
-- | Get the current working directory.
4956
getWorkingDir :: (MonadIO m) => m (Path Abs Dir)
50-
getWorkingDir = liftIO (canonicalizePath "." >>= parseAbsDir)
57+
getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)
5158

5259
-- | Appends a stringly-typed relative path to an absolute path, and then
5360
-- canonicalizes it.
@@ -84,7 +91,7 @@ resolveCheckParse check parse x y = do
8491
exists <- liftIO $ check fp
8592
if exists
8693
then do
87-
canonic <- liftIO $ canonicalizePath fp
94+
canonic <- liftIO $ D.canonicalizePath fp
8895
liftM Just (parse canonic)
8996
else return Nothing
9097

@@ -93,23 +100,23 @@ resolveCheckParse check parse x y = do
93100
-- be canonicalized, 'Nothing' is returned).
94101
resolveDirMaybe :: (MonadIO m,MonadThrow m)
95102
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))
96-
resolveDirMaybe = resolveCheckParse doesDirectoryExist parseAbsDir
103+
resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir
97104

98105
-- | Appends a stringly-typed relative path to an absolute path, and then
99106
-- canonicalizes it. If the path doesn't exist (and therefore cannot
100107
-- be canonicalized, 'Nothing' is returned).
101108
resolveFileMaybe :: (MonadIO m,MonadThrow m)
102109
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
103-
resolveFileMaybe = resolveCheckParse doesFileExist parseAbsFile
110+
resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile
104111

105112
-- | List objects in a directory, excluding "@.@" and "@..@". Entries are not sorted.
106113
listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])
107114
listDirectory dir =
108-
do entriesFP <- liftIO (getDirectoryContents dirFP)
115+
do entriesFP <- liftIO (D.getDirectoryContents dirFP)
109116
maybeEntries <-
110117
forM (map (dirFP ++) entriesFP)
111118
(\entryFP ->
112-
do isDir <- liftIO (doesDirectoryExist entryFP)
119+
do isDir <- liftIO (D.doesDirectoryExist entryFP)
113120
if isDir
114121
then case parseAbsDir entryFP of
115122
Nothing -> return Nothing
@@ -124,97 +131,78 @@ listDirectory dir =
124131
return (lefts entries,rights entries)
125132
where dirFP = toFilePath dir
126133

127-
-- | Remove the given file. Optimistically assumes it exists. If it
128-
-- doesn't, doesn't complain.
134+
-- | Remove a file. Bails out if it doesn't exist.
135+
removeFile :: MonadIO m => Path b File -> m ()
136+
removeFile = liftIO . D.removeFile . toFilePath
137+
138+
-- | Remove a file. Optimistically assumes it exists. If it doesn't,
139+
-- doesn't complain.
129140
removeFileIfExists :: MonadIO m => Path b File -> m ()
130-
removeFileIfExists fp =
131-
liftIO (catch
132-
(removeFile
133-
(toFilePath fp))
134-
(\e ->
135-
if isDoesNotExistError e
136-
then return ()
137-
else throwIO e))
138-
139-
-- | Move the given file. Optimistically assumes it exists. If it
140-
-- doesn't, doesn't complain.
141-
renameFileIfExists :: MonadIO m => Path b File -> Path b File -> m ()
142-
renameFileIfExists from to =
143-
liftIO
144-
(catch
145-
(renameFile (toFilePath from)
146-
(toFilePath to))
147-
(\e ->
148-
if isDoesNotExistError e
149-
then return ()
150-
else throwIO e))
151-
152-
-- | Rename the directory. Optimistically assumes it exists. If it
141+
removeFileIfExists = ignoreDoesNotExist . removeFile
142+
143+
-- | Rename a file. Bails out if it doesn't exist.
144+
renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
145+
renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to))
146+
147+
-- | Rename a file. Optimistically assumes it exists. If it doesn't,
148+
-- doesn't complain.
149+
renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
150+
renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)
151+
152+
renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
153+
renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))
154+
155+
-- | Rename a directory. Optimistically assumes it exists. If it
153156
-- doesn't, doesn't complain.
154-
renameDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()
155-
renameDirIfExists from to =
156-
liftIO
157-
(catch
158-
(renameDirectory (toFilePath from)
159-
(toFilePath to))
160-
(\e ->
161-
if isDoesNotExistError e
162-
then return ()
163-
else throwIO e))
157+
renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
158+
renameDirIfExists from to = ignoreDoesNotExist (renameDir from to)
164159

165160
-- | Make a directory tree, creating parents if needed.
166161
createTree :: MonadIO m => Path b Dir -> m ()
167-
createTree = liftIO . createDirectoryIfMissing True . toFilePath
162+
createTree = liftIO . D.createDirectoryIfMissing True . toFilePath
168163

169-
-- | Move the given file. Optimistically assumes it exists. If it
170-
-- doesn't, doesn't complain.
171-
moveFileIfExists :: MonadIO m => Path b File -> Path b Dir -> m ()
172-
moveFileIfExists from to =
173-
liftIO
174-
(catch
175-
(renameFile (toFilePath from)
176-
(toFilePath (to </> filename from)))
177-
(\e ->
178-
if isDoesNotExistError e
179-
then return ()
180-
else throwIO e))
181-
182-
-- | Move the given dir. Optimistically assumes it exists. If it
183-
-- doesn't, doesn't complain.
184-
moveDirIfExists :: MonadIO m => Path b Dir -> Path b Dir -> m ()
185-
moveDirIfExists from to =
186-
liftIO
187-
(catch
188-
(renameDirectory
189-
(toFilePath from)
190-
(toFilePath (to </> dirname from)))
191-
(\e ->
192-
if isDoesNotExistError e
193-
then return ()
194-
else throwIO e))
195-
196-
-- | Remove the given tree. Bails out if the directory doesn't exist.
164+
-- | Move a file. Bails out if it doesn't exist.
165+
moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
166+
moveFile from to = renameFile from (to </> filename from)
167+
168+
-- | Move a file. Optimistically assumes it exists. If it doesn't,
169+
-- doesn't complain.
170+
moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
171+
moveFileIfExists from to = ignoreDoesNotExist (moveFile from to)
172+
173+
-- | Move a dir. Bails out if it doesn't exist.
174+
moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
175+
moveDir from to = renameDir from (to </> dirname from)
176+
177+
-- | Move a dir. Optimistically assumes it exists. If it doesn't,
178+
-- doesn't complain.
179+
moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
180+
moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)
181+
182+
-- | Remove a tree. Bails out if it doesn't exist.
197183
removeTree :: MonadIO m => Path b Dir -> m ()
198-
removeTree =
199-
liftIO . removeDirectoryRecursive . toFilePath
184+
removeTree = liftIO . D.removeDirectoryRecursive . toFilePath
200185

201186
-- | Remove tree, don't complain about non-existent directories.
202187
removeTreeIfExists :: MonadIO m => Path b Dir -> m ()
203-
removeTreeIfExists fp = do
204-
liftIO (catch (removeTree fp)
205-
(\e -> if isDoesNotExistError e
206-
then return ()
207-
else throwIO e))
188+
removeTreeIfExists = ignoreDoesNotExist . removeTree
208189

209-
-- | Does the given file exist?
190+
-- | Does the file exist?
210191
fileExists :: MonadIO m => Path b File -> m Bool
211-
fileExists =
212-
liftIO . doesFileExist . toFilePath
192+
fileExists = liftIO . D.doesFileExist . toFilePath
213193

214-
-- | Does the given directory exist?
194+
-- | Does the directory exist?
215195
dirExists :: MonadIO m => Path b Dir -> m Bool
216-
dirExists =
217-
liftIO . doesDirectoryExist . toFilePath
196+
dirExists = liftIO . D.doesDirectoryExist . toFilePath
197+
198+
-- | Copies a file to another path. Bails out if it doesn't exist.
199+
copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
200+
copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))
201+
202+
-- | Copies a file to another path. Optimistically assumes it exists. If
203+
-- it doesn't, doesn't complain.
204+
copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
205+
copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)
218206

219207
-- | Copy a directory recursively. This just uses 'copyFile', so it is not smart about symbolic
220208
-- links or other special files.
@@ -223,16 +211,20 @@ copyDirectoryRecursive :: (MonadIO m,MonadThrow m)
223211
-> Path Abs Dir -- ^ Destination directory
224212
-> m ()
225213
copyDirectoryRecursive srcDir destDir =
226-
do liftIO (createDirectoryIfMissing False (toFilePath destDir))
214+
do liftIO (D.createDirectoryIfMissing False (toFilePath destDir))
227215
(srcSubDirs,srcFiles) <- listDirectory srcDir
228216
forM_ srcFiles
229217
(\srcFile ->
230218
case stripDir srcDir srcFile of
231219
Nothing -> return ()
232-
Just relFile -> liftIO (copyFile (toFilePath srcFile)
233-
(toFilePath (destDir </> relFile))))
220+
Just relFile -> copyFile srcFile (destDir </> relFile))
234221
forM_ srcSubDirs
235222
(\srcSubDir ->
236223
case stripDir srcDir srcSubDir of
237224
Nothing -> return ()
238225
Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir </> relSubDir))
226+
227+
-- Utility function for a common pattern of ignoring does-not-exist errors.
228+
ignoreDoesNotExist :: MonadIO m => IO () -> m ()
229+
ignoreDoesNotExist f =
230+
liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)

‎src/Stack/Build/Cache.hs‎

Lines changed: 6 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ module Stack.Build.Cache
2828
, checkBenchBuilt
2929
) where
3030

31-
import Control.Exception.Enclosed (catchIO, handleIO, tryIO)
31+
import Control.Exception.Enclosed (handleIO, tryIO)
3232
import Control.Monad.Catch (MonadThrow, catch, throwM)
3333
import Control.Monad.IO.Class
3434
import Control.Monad.Logger (MonadLogger)
@@ -45,9 +45,6 @@ import Path.IO
4545
import Stack.Build.Types
4646
import Stack.Constants
4747
import Stack.Types
48-
import System.Directory (createDirectoryIfMissing,
49-
getDirectoryContents,
50-
removeFile)
5148
import System.IO.Error (isDoesNotExistError)
5249

5350
-- | Directory containing files to mark an executable as installed
@@ -61,15 +58,15 @@ getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow
6158
=> InstallLocation -> m [PackageIdentifier]
6259
getInstalledExes loc = do
6360
dir <- exeInstalledDir loc
64-
files <- liftIO $ handleIO (const $ return []) $ getDirectoryContents $ toFilePath dir
65-
return $ mapMaybe parsePackageIdentifierFromString files
61+
(_, files) <- liftIO $ handleIO (const $ return ([], [])) $ listDirectory dir
62+
return $ mapMaybe (parsePackageIdentifierFromString . toFilePath) files
6663

6764
-- | Mark the given executable as installed
6865
markExeInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
6966
=> InstallLocation -> PackageIdentifier -> m ()
7067
markExeInstalled loc ident = do
7168
dir <- exeInstalledDir loc
72-
liftIO $ createDirectoryIfMissing True $ toFilePath dir
69+
createTree dir
7370
ident' <- parseRelFile $ packageIdentifierString ident
7471
let fp = toFilePath $ dir </> ident'
7572
-- TODO consideration for the future: list all of the executables
@@ -83,8 +80,7 @@ markExeNotInstalled :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThr
8380
markExeNotInstalled loc ident = do
8481
dir <- exeInstalledDir loc
8582
ident' <- parseRelFile $ packageIdentifierString ident
86-
let fp = toFilePath $ dir </> ident'
87-
liftIO $ catchIO (removeFile fp) (\_ -> return ())
83+
removeFileIfExists (dir </> ident')
8884

8985
-- | Stored on disk to know whether the flags have changed or any
9086
-- files have changed.
@@ -205,8 +201,7 @@ writeFlagCache :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
205201
writeFlagCache gid cache = do
206202
file <- flagCacheFile gid
207203
liftIO $ do
208-
createDirectoryIfMissing True $ toFilePath $ parent file
209-
204+
createTree (parent file)
210205
Binary.encodeFile (toFilePath file) cache
211206

212207
-- | Mark a test suite as having succeeded

‎src/Stack/Build/Execute.hs‎

Lines changed: 9 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -64,8 +64,7 @@ import Stack.Constants
6464
import Stack.Types
6565
import Stack.Types.StackT
6666
import Stack.Types.Internal
67-
import System.Directory hiding (findExecutable,
68-
findFiles)
67+
import qualified System.Directory as D
6968
import System.Environment (getExecutablePath)
7069
import System.Exit (ExitCode (ExitSuccess))
7170
import qualified System.FilePath as FP
@@ -233,9 +232,9 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do
233232
snapBin <- (</> bindirSuffix) `liftM` installationRootDeps
234233
localBin <- (</> bindirSuffix) `liftM` installationRootLocal
235234
destDir <- asks $ configLocalBin . getConfig
236-
let destDir' = toFilePath destDir
237-
liftIO $ createDirectoryIfMissing True destDir'
235+
createTree destDir
238236

237+
let destDir' = toFilePath destDir
239238
when (not $ any (FP.equalFilePath destDir') (envSearchPath menv)) $
240239
$logWarn $ T.concat
241240
[ "Installation path "
@@ -278,7 +277,7 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do
278277
liftIO $ case platform of
279278
Platform _ Windows | FP.equalFilePath destFile currExe ->
280279
windowsRenameCopy (toFilePath file) destFile
281-
_ -> copyFile (toFilePath file) destFile
280+
_ -> D.copyFile (toFilePath file) destFile
282281
return $ Just (destDir', [T.append name (T.pack ext)])
283282

284283
let destToInstalled = Map.fromListWith (++) (catMaybes installed)
@@ -294,9 +293,9 @@ executePlan menv bopts baseConfigOpts locals sourceMap plan = do
294293
-- current executable to something else and then do the copy.
295294
windowsRenameCopy :: FilePath -> FilePath -> IO ()
296295
windowsRenameCopy src dest = do
297-
copyFile src new
298-
renameFile dest old
299-
renameFile new dest
296+
D.copyFile src new
297+
D.renameFile dest old
298+
D.renameFile new dest
300299
where
301300
new = dest ++ ".new"
302301
old = dest ++ ".old"
@@ -434,7 +433,7 @@ ensureConfig pkgDir ExecuteEnv {..} Task {..} announce cabal cabalfp extra = do
434433
mOldConfigCache <- tryGetConfigCache pkgDir
435434

436435
mOldCabalMod <- tryGetCabalMod pkgDir
437-
newCabalMod <- liftIO (fmap modTime (getModificationTime (toFilePath cabalfp)))
436+
newCabalMod <- liftIO (fmap modTime (D.getModificationTime (toFilePath cabalfp)))
438437

439438
idMap <- liftIO $ readTVarIO eeGhcPkgIds
440439
let getMissing ident =
@@ -521,7 +520,7 @@ withSingleContext ActionContext {..} ExecuteEnv {..} task@Task {..} inner0 =
521520
| console = inner Nothing
522521
| otherwise = do
523522
logPath <- buildLogPath package -- TODO give a difference suffix for test, bench, etc?
524-
liftIO $ createDirectoryIfMissing True $ toFilePath $ parent logPath
523+
createTree (parent logPath)
525524
let fp = toFilePath logPath
526525
bracket
527526
(liftIO $ openBinaryFile fp WriteMode)

0 commit comments

Comments
 (0)