Move file system operations to the library

See #347

src/Hadrian/Oracles/DirectoryContents.hs

 module Hadrian.Oracles.DirectoryContents (
-    directoryContents, directoryContentsOracle, Match (..), matchAll
+    directoryContents, copyDirectoryContents, directoryContentsOracle,
+    Match (..), matches, matchAll
     ) where
 
 import Control.Monad
 import Development.Shake
 import Development.Shake.Classes
+import Development.Shake.FilePath
 import GHC.Generics
-import System.Directory.Extra
 
 import Hadrian.Utilities
 
+import qualified System.Directory.Extra as IO
+
 data Match = Test FilePattern | Not Match | And [Match] | Or [Match]
     deriving (Generic, Eq, Show, Typeable)
 
@@ -33,6 +36,14 @@ matches (Or  ms) f = any (`matches` f) ms
 directoryContents :: Match -> FilePath -> Action [FilePath]
 directoryContents expr dir = askOracle $ DirectoryContents (expr, dir)
 
+-- | Copy the contents of the source directory that matches a given 'Match'
+-- expression into the target directory. The copied contents is tracked.
+copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
+copyDirectoryContents expr source target = do
+    putProgressInfo =<< renderAction "Copy directory contents" source target
+    let cp file = copyFile file $ target -/- makeRelative source file
+    mapM_ cp =<< directoryContents expr source
+
 newtype DirectoryContents = DirectoryContents (Match, FilePath)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 
@@ -40,4 +51,4 @@ newtype DirectoryContents = DirectoryContents (Match, FilePath)
 directoryContentsOracle :: Rules ()
 directoryContentsOracle = void $
     addOracle $ \(DirectoryContents (expr, dir)) -> liftIO $ map unifyPath .
-        filter (matches expr) <$> listFilesInside (return . matches expr) dir
+        filter (matches expr) <$> IO.listFilesInside (return . matches expr) dir

src/Hadrian/Oracles/Path.hs

 module Hadrian.Oracles.Path (
-    lookupInPath, fixAbsolutePathOnWindows, pathOracle
+    lookupInPath, bashPath, fixAbsolutePathOnWindows, pathOracle
     ) where
 
 import Control.Monad
@@ -20,6 +20,10 @@ lookupInPath name
     | name == takeFileName name = askOracle $ LookupInPath name
     | otherwise                 = return name
 
+-- | Lookup the path to the @bash@ interpreter.
+bashPath :: Action FilePath
+bashPath = lookupInPath "bash"
+
 -- | Fix an absolute path on Windows:
 -- * "/c/" => "C:/"
 -- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"

src/Hadrian/Utilities.hs

@@ -11,6 +11,10 @@ module Hadrian.Utilities (
     -- * Accessing Shake's type-indexed map
     insertExtra, userSetting,
 
+    -- * File system operations
+    copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
+    createDirectory, copyDirectory, moveDirectory, removeDirectory,
+
     -- * Diagnostic info
     UseColour (..), putColoured, BuildProgressColour (..), putBuild,
     SuccessColour (..), putSuccess, ProgressInfo (..),
@@ -18,19 +22,23 @@ module Hadrian.Utilities (
     renderUnicorn
     ) where
 
-import Control.Monad
+import Control.Monad.Extra
 import Data.Char
-import Data.Dynamic
+import Data.Dynamic (Dynamic, fromDynamic, toDyn)
 import Data.HashMap.Strict (HashMap)
 import Data.List.Extra
 import Data.Maybe
+import Data.Typeable (TypeRep, typeOf)
 import Development.Shake hiding (Normal)
+import Development.Shake.Classes
 import Development.Shake.FilePath
 import System.Console.ANSI
-import System.Info.Extra
-import System.IO
 
-import qualified Data.HashMap.Strict as Map
+import qualified Control.Exception.Base as IO
+import qualified Data.HashMap.Strict    as Map
+import qualified System.Directory.Extra as IO
+import qualified System.Info.Extra      as IO
+import qualified System.IO              as IO
 
 -- | Extract a value from a singleton list, or terminate with an error message
 -- if the list does not contain exactly one value.
@@ -131,19 +139,89 @@ userSetting defaultValue = do
     let maybeValue = fromDynamic =<< Map.lookup (typeOf defaultValue) extra
     return $ fromMaybe defaultValue maybeValue
 
+-- | Copy a file tracking the source. Create the target directory if missing.
+copyFile :: FilePath -> FilePath -> Action ()
+copyFile source target = do
+    need [source] -- Guarantee the source is built before printing progress info.
+    let dir = takeDirectory target
+    liftIO $ IO.createDirectoryIfMissing True dir
+    putProgressInfo =<< renderAction "Copy file" source target
+    copyFileChanged source target
+
+-- | Copy a file without tracking the source. Create the target directory if missing.
+copyFileUntracked :: FilePath -> FilePath -> Action ()
+copyFileUntracked source target = do
+    let dir = takeDirectory target
+    liftIO $ IO.createDirectoryIfMissing True dir
+    putProgressInfo =<< renderAction "Copy file (untracked)" source target
+    liftIO $ IO.copyFile source target
+
+-- | Transform a given file by applying a function to its contents.
+fixFile :: FilePath -> (String -> String) -> Action ()
+fixFile file f = do
+    putBuild $ "| Fix " ++ file
+    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
+        old <- IO.hGetContents h
+        let new = f old
+        IO.evaluate $ rnf new
+        return new
+    liftIO $ writeFile file contents
+
+-- | Make a given file executable by running the @chmod +x@ command.
+makeExecutable :: FilePath -> Action ()
+makeExecutable file = do
+    putBuild $ "| Make " ++ quote file ++ " executable."
+    quietly $ cmd "chmod +x " [file]
+
+-- | Move a file. Note that we cannot track the source, because it is moved.
+moveFile :: FilePath -> FilePath -> Action ()
+moveFile source target = do
+    putProgressInfo =<< renderAction "Move file" source target
+    quietly $ cmd ["mv", source, target]
+
+-- | Remove a file that doesn't necessarily exist.
+removeFile :: FilePath -> Action ()
+removeFile file = do
+    putBuild $ "| Remove file " ++ file
+    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
+
+-- | Create a directory if it does not already exist.
+createDirectory :: FilePath -> Action ()
+createDirectory dir = do
+    putBuild $ "| Create directory " ++ dir
+    liftIO $ IO.createDirectoryIfMissing True dir
+
+-- | Copy a directory. The contents of the source directory is untracked.
+copyDirectory :: FilePath -> FilePath -> Action ()
+copyDirectory source target = do
+    putProgressInfo =<< renderAction "Copy directory" source target
+    quietly $ cmd ["cp", "-r", source, target]
+
+-- | Move a directory. The contents of the source directory is untracked.
+moveDirectory :: FilePath -> FilePath -> Action ()
+moveDirectory source target = do
+    putProgressInfo =<< renderAction "Move directory" source target
+    quietly $ cmd ["mv", source, target]
+
+-- | Remove a directory that doesn't necessarily exist.
+removeDirectory :: FilePath -> Action ()
+removeDirectory dir = do
+    putBuild $ "| Remove directory " ++ dir
+    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
+
 data UseColour = Never | Auto | Always deriving (Eq, Show, Typeable)
 
 -- | A more colourful version of Shake's 'putNormal'.
 putColoured :: ColorIntensity -> Color -> String -> Action ()
 putColoured intensity colour msg = do
     useColour <- userSetting Never
-    supported <- liftIO $ hSupportsANSI stdout
+    supported <- liftIO $ hSupportsANSI IO.stdout
     let c Never  = False
-        c Auto   = supported || isWindows -- Colours do work on Windows
+        c Auto   = supported || IO.isWindows -- Colours do work on Windows
         c Always = True
     when (c useColour) . liftIO $ setSGR [SetColor Foreground intensity colour]
     putNormal msg
-    when (c useColour) . liftIO $ setSGR [] >> hFlush stdout
+    when (c useColour) . liftIO $ setSGR [] >> IO.hFlush IO.stdout
 
 newtype BuildProgressColour = BuildProgressColour (ColorIntensity, Color)
     deriving Typeable
@@ -173,7 +251,7 @@ putSuccess msg = do
 
 data ProgressInfo = None | Brief | Normal | Unicorn deriving (Eq, Show, Typeable)
 
--- | Version of 'putBuild' controlled by @--progress-info@ command line flag.
+-- | Version of 'putBuild' controlled by @--progress-info@ command line argument.
 putProgressInfo :: String -> Action ()
 putProgressInfo msg = do
     progressInfo <- userSetting None

src/Rules/Clean.hs

@@ -3,7 +3,6 @@ module Rules.Clean (clean, cleanSourceTree, cleanRules) where
 import Base
 import Settings.Path
 import UserSettings
-import Utilities
 
 clean :: Action ()
 clean = do

src/Rules/Wrappers.hs

@@ -2,6 +2,8 @@ module Rules.Wrappers (
     WrappedBinary(..), Wrapper, inplaceWrappers, installWrappers
     ) where
 
+import Hadrian.Oracles.Path
+
 import Base
 import Expression
 import GHC
@@ -9,7 +11,6 @@ import Oracles.Setting
 import Settings
 import Settings.Install
 import Settings.Path
-import Utilities
 
 -- | Wrapper is an expression depending on the 'FilePath' to the
 -- | library path and name of the wrapped binary.

src/Utilities.hs

 module Utilities (
-    build, buildWithCmdOptions, buildWithResources, copyFile, fixFile, moveFile,
-    removeFile, copyDirectory, copyDirectoryContents, createDirectory,
-    moveDirectory, removeDirectory, applyPatch, runBuilder, runBuilderWith,
-    makeExecutable, renderProgram, renderLibrary, builderEnvironment,
-    needBuilder, copyFileUntracked, installDirectory, installData, installScript,
-    installProgram, linkSymbolic, bashPath, contextDependencies, pkgDependencies,
-    libraryTargets, needLibrary, topsortPackages
+    build, buildWithCmdOptions, buildWithResources, applyPatch, runBuilder,
+    runBuilderWith, builderEnvironment, needBuilder, needLibrary,
+    installDirectory, installData, installScript, installProgram, linkSymbolic,
+    contextDependencies, pkgDependencies, libraryTargets, topsortPackages
     ) where
 
 import qualified System.Directory.Extra as IO
-import qualified System.IO              as IO
-import qualified Control.Exception.Base as IO
 
 import Hadrian.Oracles.ArgsHash
-import Hadrian.Oracles.DirectoryContents
 import Hadrian.Oracles.KeyValue
 import Hadrian.Oracles.Path
 import Hadrian.Utilities
@@ -108,78 +102,6 @@ captureStdout target path argList = do
     Stdout output <- cmd [path] argList
     writeFileChanged file output
 
--- | Copy a file tracking the source, create the target directory if missing.
-copyFile :: FilePath -> FilePath -> Action ()
-copyFile source target = do
-    need [source] -- Guarantee source is built before printing progress info.
-    let dir = takeDirectory target
-    liftIO $ IO.createDirectoryIfMissing True dir
-    putProgressInfo =<< renderAction "Copy file" source target
-    copyFileChanged source target
-
--- | Copy a file without tracking the source, create the target directory if missing.
-copyFileUntracked :: FilePath -> FilePath -> Action ()
-copyFileUntracked source target = do
-    let dir = takeDirectory target
-    liftIO $ IO.createDirectoryIfMissing True dir
-    putProgressInfo =<< renderAction "Copy file (Untracked)" source target
-    liftIO $ IO.copyFile source target
-
--- | Move a file; we cannot track the source, because it is moved.
-moveFile :: FilePath -> FilePath -> Action ()
-moveFile source target = do
-    putProgressInfo =<< renderAction "Move file" source target
-    quietly $ cmd ["mv", source, target]
-
--- | Remove a file that doesn't necessarily exist.
-removeFile :: FilePath -> Action ()
-removeFile file = do
-    putBuild $ "| Remove file " ++ file
-    liftIO . whenM (IO.doesFileExist file) $ IO.removeFile file
-
--- | Create a directory if it does not already exist.
-createDirectory :: FilePath -> Action ()
-createDirectory dir = do
-    putBuild $ "| Create directory " ++ dir
-    liftIO $ IO.createDirectoryIfMissing True dir
-
--- | Remove a directory that doesn't necessarily exist.
-removeDirectory :: FilePath -> Action ()
-removeDirectory dir = do
-    putBuild $ "| Remove directory " ++ dir
-    liftIO . whenM (IO.doesDirectoryExist dir) $ IO.removeDirectoryRecursive dir
-
--- | Copy a directory. The contents of the source directory is untracked.
-copyDirectory :: FilePath -> FilePath -> Action ()
-copyDirectory source target = do
-    putProgressInfo =<< renderAction "Copy directory" source target
-    quietly $ cmd ["cp", "-r", source, target]
-
--- | Copy the contents of the source directory that matches a given 'Match'
--- expression into the target directory. The copied contents is tracked.
-copyDirectoryContents :: Match -> FilePath -> FilePath -> Action ()
-copyDirectoryContents expr source target = do
-    putProgressInfo =<< renderAction "Copy directory contents" source target
-    let cp file = copyFile file $ target -/- makeRelative source file
-    mapM_ cp =<< directoryContents expr source
-
--- | Move a directory. The contents of the source directory is untracked.
-moveDirectory :: FilePath -> FilePath -> Action ()
-moveDirectory source target = do
-    putProgressInfo =<< renderAction "Move directory" source target
-    quietly $ cmd ["mv", source, target]
-
--- | Transform a given file by applying a function to its contents.
-fixFile :: FilePath -> (String -> String) -> Action ()
-fixFile file f = do
-    putBuild $ "| Fix " ++ file
-    contents <- liftIO $ IO.withFile file IO.ReadMode $ \h -> do
-        old <- IO.hGetContents h
-        let new = f old
-        IO.evaluate $ rnf new
-        return new
-    liftIO $ writeFile file contents
-
 -- | Apply a patch by executing the 'Patch' builder in a given directory.
 applyPatch :: FilePath -> FilePath -> Action ()
 applyPatch dir patch = do
@@ -262,16 +184,6 @@ runBuilderWith options builder args = do
     putBuild $ "| Run " ++ show builder ++ note
     quietly $ cmd options [path] args
 
--- | Make a given file executable by running the @chmod@ command.
-makeExecutable :: FilePath -> Action ()
-makeExecutable file = do
-    putBuild $ "| Make " ++ quote file ++ " executable."
-    quietly $ cmd "chmod +x " [file]
-
--- | Lookup the path to the @bash@ interpreter.
-bashPath :: Action FilePath
-bashPath = lookupInPath "bash"
-
 -- | Given a 'Context' this 'Action' looks up its package dependencies in
 -- 'Settings.Paths.packageDependencies' and wraps the results in appropriate
 -- contexts. The only subtlety here is that we never depend on packages built in
@@ -335,4 +247,3 @@ putInfo t = putProgressInfo =<< renderAction
     digest [] = "none"
     digest [x] = x
     digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"
-