Commit 58e2d050 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Move file system operations to the library

See #347
parent 0530e0df
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
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"
......
......@@ -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
......
......@@ -3,7 +3,6 @@ module Rules.Clean (clean, cleanSourceTree, cleanRules) where
import Base
import Settings.Path
import UserSettings
import Utilities
clean :: Action ()
clean = do
......
......@@ -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.
......
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)"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment