Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
58e2d050
Commit
58e2d050
authored
Aug 15, 2017
by
Andrey Mokhov
Browse files
Move file system operations to the library
See
#347
parent
0530e0df
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/Hadrian/Oracles/DirectoryContents.hs
View file @
58e2d050
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
View file @
58e2d050
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
View file @
58e2d050
...
...
@@ -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
View file @
58e2d050
...
...
@@ -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
View file @
58e2d050
...
...
@@ -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
View file @
58e2d050
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)"
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment