Factor out file cache functionality into the library
[hadrian.git] / src / Utilities.hs
1 module Utilities (
2 build, buildWithCmdOptions, buildWithResources, applyPatch, runBuilder,
3 runBuilderWith, builderEnvironment, needBuilder, needLibrary,
4 installDirectory, installData, installScript, installProgram, linkSymbolic,
5 contextDependencies, pkgDependencies, libraryTargets, topsortPackages,
6 packageDependenciesGenerator
7 ) where
8
9 import qualified System.Directory.Extra as IO
10
11 import Hadrian.Haskell.Cabal
12 import Hadrian.Oracles.ArgsHash
13 import Hadrian.Oracles.KeyValue
14 import Hadrian.Oracles.Path
15 import Hadrian.Utilities
16
17 import CommandLine
18 import Context
19 import Expression hiding (builder, inputs, outputs, way, stage, package)
20 import GHC
21 import Oracles.Setting
22 import Oracles.PackageData
23 import Settings
24 import Settings.Builders.Ar
25 import Target
26 import UserSettings
27
28 -- | Build a 'Target' with the right 'Builder' and command line arguments.
29 -- Force a rebuild if the argument list has changed since the last build.
30 build :: Target -> Action ()
31 build = customBuild [] []
32
33 -- | Build a 'Target' with the right 'Builder' and command line arguments,
34 -- acquiring necessary resources. Force a rebuild if the argument list has
35 -- changed since the last build.
36 buildWithResources :: [(Resource, Int)] -> Target -> Action ()
37 buildWithResources rs = customBuild rs []
38
39 -- | Build a 'Target' with the right 'Builder' and command line arguments,
40 -- using given options when executing the build command. Force a rebuild if
41 -- the argument list has changed since the last build.
42 buildWithCmdOptions :: [CmdOption] -> Target -> Action ()
43 buildWithCmdOptions = customBuild []
44
45 customBuild :: [(Resource, Int)] -> [CmdOption] -> Target -> Action ()
46 customBuild rs opts target = do
47 let targetBuilder = builder target
48 needBuilder targetBuilder
49 path <- builderPath targetBuilder
50 argList <- interpret target getArgs
51 verbose <- interpret target verboseCommands
52 let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
53 trackArgsHash target -- Rerun the rule if the hash of argList has changed.
54 withResources rs $ do
55 putInfo target
56 quietlyUnlessVerbose $ case targetBuilder of
57 Ar _ -> do
58 output <- interpret target getOutput
59 if "//*.a" ?== output
60 then arCmd path argList
61 else do
62 input <- interpret target getInput
63 top <- topDirectory
64 echo <- cmdEcho
65 cmd echo [Cwd output] [path] "x" (top -/- input)
66
67 Configure dir -> do
68 -- Inject /bin/bash into `libtool`, instead of /bin/sh, otherwise Windows breaks.
69 -- TODO: Figure out why.
70 bash <- bashPath
71 echo <- cmdEcho
72 let env = AddEnv "CONFIG_SHELL" bash
73 cmd Shell echo env [Cwd dir] [path] opts argList
74
75 HsCpp -> captureStdout target path argList
76 GenApply -> captureStdout target path argList
77
78 GenPrimopCode -> do
79 src <- interpret target getInput
80 file <- interpret target getOutput
81 input <- readFile' src
82 Stdout output <- cmd (Stdin input) [path] argList
83 writeFileChanged file output
84
85 Make dir -> do
86 echo <- cmdEcho
87 cmd Shell echo path ["-C", dir] argList
88
89 _ -> do
90 echo <- cmdEcho
91 cmd echo [path] argList
92
93 -- | Suppress build output depending on the @--progress-info@ flag.
94 cmdEcho :: Action CmdOption
95 cmdEcho = do
96 progressInfo <- cmdProgressInfo
97 return $ EchoStdout (progressInfo `elem` [Normal, Unicorn])
98
99 -- | Run a builder, capture the standard output, and write it to a given file.
100 captureStdout :: Target -> FilePath -> [String] -> Action ()
101 captureStdout target path argList = do
102 file <- interpret target getOutput
103 Stdout output <- cmd [path] argList
104 writeFileChanged file output
105
106 -- | Apply a patch by executing the 'Patch' builder in a given directory.
107 applyPatch :: FilePath -> FilePath -> Action ()
108 applyPatch dir patch = do
109 let file = dir -/- patch
110 needBuilder Patch
111 path <- builderPath Patch
112 putBuild $ "| Apply patch " ++ file
113 quietly $ cmd Shell [Cwd dir] [path, "-p0 <", patch]
114
115 -- | Install a directory.
116 installDirectory :: FilePath -> Action ()
117 installDirectory dir = do
118 path <- fixAbsolutePathOnWindows =<< setting InstallDir
119 putBuild $ "| Install directory " ++ dir
120 quietly $ cmd path dir
121
122 -- | Install data files to a directory and track them.
123 installData :: [FilePath] -> FilePath -> Action ()
124 installData fs dir = do
125 path <- fixAbsolutePathOnWindows =<< setting InstallData
126 need fs
127 forM_ fs $ \f -> putBuild $ "| Install data " ++ f ++ " to " ++ dir
128 quietly $ cmd path fs dir
129
130 -- | Install an executable file to a directory and track it.
131 installProgram :: FilePath -> FilePath -> Action ()
132 installProgram f dir = do
133 path <- fixAbsolutePathOnWindows =<< setting InstallProgram
134 need [f]
135 putBuild $ "| Install program " ++ f ++ " to " ++ dir
136 quietly $ cmd path f dir
137
138 -- | Install an executable script to a directory and track it.
139 installScript :: FilePath -> FilePath -> Action ()
140 installScript f dir = do
141 path <- fixAbsolutePathOnWindows =<< setting InstallScript
142 need [f]
143 putBuild $ "| Install script " ++ f ++ " to " ++ dir
144 quietly $ cmd path f dir
145
146 -- | Create a symbolic link from source file to target file (when symbolic links
147 -- are supported) and track the source file.
148 linkSymbolic :: FilePath -> FilePath -> Action ()
149 linkSymbolic source target = do
150 lns <- setting LnS
151 unless (null lns) $ do
152 need [source] -- Guarantee source is built before printing progress info.
153 let dir = takeDirectory target
154 liftIO $ IO.createDirectoryIfMissing True dir
155 putProgressInfo =<< renderAction "Create symbolic link" source target
156 quietly $ cmd lns source target
157
158 isInternal :: Builder -> Bool
159 isInternal = isJust . builderProvenance
160
161 -- | Make sure a 'Builder' exists and rebuild it if out of date.
162 needBuilder :: Builder -> Action ()
163 needBuilder (Configure dir) = need [dir -/- "configure"]
164 needBuilder (Make dir) = need [dir -/- "Makefile"]
165 needBuilder builder = when (isInternal builder) $ do
166 path <- builderPath builder
167 need [path]
168
169 -- | Write a Builder's path into a given environment variable.
170 builderEnvironment :: String -> Builder -> Action CmdOption
171 builderEnvironment variable builder = do
172 needBuilder builder
173 path <- builderPath builder
174 return $ AddEnv variable path
175
176 runBuilder :: Builder -> [String] -> Action ()
177 runBuilder = runBuilderWith []
178
179 -- | Run a builder with given list of arguments using custom 'cmd' options.
180 runBuilderWith :: [CmdOption] -> Builder -> [String] -> Action ()
181 runBuilderWith options builder args = do
182 needBuilder builder
183 path <- builderPath builder
184 let note = if null args then "" else " (" ++ intercalate ", " args ++ ")"
185 putBuild $ "| Run " ++ show builder ++ note
186 quietly $ cmd options [path] args
187
188 packageDependenciesGenerator :: FilePath -> Action String
189 packageDependenciesGenerator _ = do
190 pkgDeps <- forM (sort knownPackages) $ \pkg -> do
191 exists <- doesFileExist (pkgCabalFile pkg)
192 if not exists then return (pkgNameString pkg)
193 else do
194 deps <- nubOrd . sort <$> cabalDependencies (pkgCabalFile pkg)
195 return . unwords $ pkgNameString pkg : (deps \\ [pkgNameString pkg])
196 return (unlines pkgDeps)
197
198 -- | Given a 'Context' this 'Action' looks up its package dependencies in
199 -- 'Base.packageDependencies' and wraps the results in appropriate contexts.
200 -- The only subtlety here is that we never depend on packages built in 'Stage2'
201 -- or later, therefore the stage of the resulting dependencies is bounded from
202 -- above at 'Stage1'. To compute package dependencies we scan package cabal
203 -- files, see 'cabalDependencies' defined in "Hadrian.Haskell.Cabal".
204 contextDependencies :: Context -> Action [Context]
205 contextDependencies Context {..} = do
206 let pkgContext = \pkg -> Context (min stage Stage1) pkg way
207 -- 'packageDependencies' is generated by 'packageDependenciesGenerator'.
208 path <- buildRoot <&> (-/- packageDependencies)
209 deps <- lookupValuesOrError path (pkgNameString package)
210 pkgs <- sort <$> interpretInContext (pkgContext package) getPackages
211 return . map pkgContext $ intersectOrd (compare . pkgNameString) pkgs deps
212
213 -- | Lookup dependencies of a 'Package' in the vanilla Stage1 context.
214 pkgDependencies :: Package -> Action [Package]
215 pkgDependencies = fmap (map Context.package) . contextDependencies . vanillaContext Stage1
216
217 -- | Given a library 'Package' this action computes all of its targets.
218 libraryTargets :: Context -> Action [FilePath]
219 libraryTargets context = do
220 confFile <- pkgConfFile context
221 libFile <- pkgLibraryFile context
222 lib0File <- pkgLibraryFile0 context
223 lib0 <- buildDll0 context
224 ghciLib <- pkgGhciLibraryFile context
225 ghciFlag <- interpretInContext context $ getPkgData BuildGhciLib
226 let ghci = ghciFlag == "YES" && (stage context == Stage1 || stage1Only)
227 return $ [ confFile, libFile ] ++ [ lib0File | lib0 ] ++ [ ghciLib | ghci ]
228
229 -- | Coarse-grain 'need': make sure all given libraries are fully built.
230 needLibrary :: [Context] -> Action ()
231 needLibrary cs = need =<< concatMapM libraryTargets cs
232
233 -- HACK (izgzhen), see https://github.com/snowleopard/hadrian/issues/344.
234 -- | Topological sort of packages according to their dependencies.
235 topsortPackages :: [Package] -> Action [Package]
236 topsortPackages pkgs = do
237 elems <- mapM (\p -> (p,) <$> pkgDependencies p) pkgs
238 return $ map fst $ topSort elems
239 where
240 annotateInDeg es e =
241 (foldr (\e' s -> if fst e' `elem` snd e then s + 1 else s) (0 :: Int) es, e)
242 topSort [] = []
243 topSort es =
244 let annotated = map (annotateInDeg es) es
245 inDegZero = map snd $ filter ((== 0). fst) annotated
246 in inDegZero ++ topSort (es \\ inDegZero)
247
248 -- | Print out information about the command being executed.
249 putInfo :: Target -> Action ()
250 putInfo t = putProgressInfo =<< renderAction
251 ("Run " ++ show (builder t) ++ contextInfo)
252 (digest $ inputs t)
253 (digest $ outputs t)
254 where
255 contextInfo = concat $ [ " (" ]
256 ++ [ "stage = " ++ show (stage $ context t) ]
257 ++ [ ", package = " ++ pkgNameString (package $ context t) ]
258 ++ [ ", way = " ++ show (way $ context t) | (way $ context t) /= vanilla ]
259 ++ [ ")" ]
260 digest [] = "none"
261 digest [x] = x
262 digest (x:xs) = x ++ " (and " ++ show (length xs) ++ " more)"