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