Builder.hs 14 KB
Newer Older
1
{-# LANGUAGE InstanceSigs #-}
2
module Builder (
3
    -- * Data types
4
5
6
    ArMode (..), CcMode (..), ConfigurationInfo (..), GhcMode (..),
    GhcPkgMode (..), HaddockMode (..), SphinxMode (..), TarMode (..),
    Builder (..),
7
8
9

    -- * Builder properties
    builderProvenance, systemBuilderPath, builderPath, isSpecified, needBuilder,
10
11
12
    runBuilder, runBuilderWith, runBuilderWithCmdOptions, getBuilderPath,
    builderEnvironment,

13
14
    -- * Ad hoc builder invocation
    applyPatch
15
    ) where
Andrey Mokhov's avatar
Andrey Mokhov committed
16

17
import Development.Shake.Classes
18
import GHC.Generics
19
20
import qualified Hadrian.Builder as H
import Hadrian.Builder hiding (Builder)
21
import Hadrian.Builder.Ar
22
import Hadrian.Builder.Sphinx
23
import Hadrian.Builder.Tar
24
25
import Hadrian.Oracles.Path
import Hadrian.Oracles.TextFile
26
import Hadrian.Utilities
27

28
29
import Base
import Context
30
31
import Oracles.Flag
import Oracles.Setting
32
import Packages
Andrey Mokhov's avatar
Andrey Mokhov committed
33

34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
-- | C compiler can be used in two different modes:
-- * Compile or preprocess a source file.
-- * Extract source dependencies by passing @-MM@ command line argument.
data CcMode = CompileC | FindCDependencies deriving (Eq, Generic, Show)

instance Binary   CcMode
instance Hashable CcMode
instance NFData   CcMode

-- | GHC can be used in four different modes:
-- * Compile a Haskell source file.
-- * Compile a C source file.
-- * Extract source dependencies by passing @-M@ command line argument.
-- * Link object files & static libraries into an executable.
data GhcMode = CompileHs | CompileCWithGhc | FindHsDependencies | LinkHs
49
    deriving (Eq, Generic, Show)
50

51
52
53
54
instance Binary   GhcMode
instance Hashable GhcMode
instance NFData   GhcMode

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
-- | To configure a package we need two pieces of information, which we choose
-- to record separately for convenience.
--
-- * Command line arguments to be passed to the setup script.
--
-- * Package configuration flags that enable/disable certain package features.
--   Here is an example from "Settings.Packages":
--
--   > package rts
--   >   ? builder (Cabal Flags)
--   >   ? any (wayUnit Profiling) rtsWays
--   >   ? arg "profiling"
--
--   This instructs package configuration functions (such as 'configurePackage')
--   to enable the @profiling@ Cabal flag when processing @rts.cabal@ and
--   building RTS with profiling information.
data ConfigurationInfo = Setup | Flags deriving (Eq, Generic, Show)

instance Binary   ConfigurationInfo
instance Hashable ConfigurationInfo
instance NFData   ConfigurationInfo

-- TODO: Do we really need all these modes? Why do we need 'Dependencies'? We
78
79
-- can extract dependencies using the Cabal library. Note: we used to also have
-- the @Init@ mode for initialising a new package database but we've deleted it.
80
-- | 'GhcPkg' can initialise a package database and register packages in it.
81
data GhcPkgMode = Copy         -- ^ Copy a package from one database to another.
82
                | Dependencies -- ^ Compute package dependencies.
83
84
                | Unregister   -- ^ Unregister a package.
                | Update       -- ^ Update a package.
85
                deriving (Eq, Generic, Show)
Andrey Mokhov's avatar
Andrey Mokhov committed
86

87
88
89
90
instance Binary   GhcPkgMode
instance Hashable GhcPkgMode
instance NFData   GhcPkgMode

91
92
93
94
95
96
97
98
99
-- | Haddock can be used in two different modes:
-- * Generate documentation for a single package
-- * Generate an index page for a collection of packages
data HaddockMode = BuildPackage | BuildIndex deriving (Eq, Generic, Show)

instance Binary   HaddockMode
instance Hashable HaddockMode
instance NFData   HaddockMode

100
101
102
103
104
105
106
107
-- | A 'Builder' is a (usually external) command invoked in a separate process
-- via 'cmd'. Here are some examples:
-- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@.
-- * 'Ghc' 'Stage0' is the bootstrapping Haskell compiler used in 'Stage0'.
-- * 'Ghc' @StageN@ (N > 0) is the GHC built in stage (N - 1) and used in @StageN@.
--
-- The 'Cabal' builder is unusual in that it does not correspond to an external
-- program but instead relies on the Cabal library for package configuration.
108
data Builder = Alex
109
             | Ar ArMode Stage
110
             | Autoreconf FilePath
111
             | DeriveConstants
112
             | Cabal ConfigurationInfo Stage
113
             | Cc CcMode Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
114
             | Configure FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
115
             | GenApply
Andrey Mokhov's avatar
Andrey Mokhov committed
116
             | GenPrimopCode
117
             | Ghc GhcMode Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
118
             | GhcPkg GhcPkgMode Stage
119
             | Haddock HaddockMode
120
             | Happy
Andrey Mokhov's avatar
Andrey Mokhov committed
121
             | Hpc
122
             | Hp2Ps
Andrey Mokhov's avatar
Andrey Mokhov committed
123
             | HsCpp
124
125
             | Hsc2Hs Stage
             | Ld Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
126
             | Make FilePath
127
128
             | Nm
             | Objdump
129
             | Patch
Moritz Angermann's avatar
Moritz Angermann committed
130
             | Perl
131
             | Python
Andrey Mokhov's avatar
Andrey Mokhov committed
132
             | Ranlib
133
             | RunTest
134
135
             | Sphinx SphinxMode
             | Tar TarMode
136
             | Unlit
137
             | Xelatex
Andrey Mokhov's avatar
Andrey Mokhov committed
138
             deriving (Eq, Generic, Show)
Andrey Mokhov's avatar
Andrey Mokhov committed
139

140
141
142
143
instance Binary   Builder
instance Hashable Builder
instance NFData   Builder

144
145
146
147
148
149
150
151
152
153
154
-- | Some builders are built by this very build system, in which case
-- 'builderProvenance' returns the corresponding build 'Context' (which includes
-- 'Stage' and GHC 'Package').
builderProvenance :: Builder -> Maybe Context
builderProvenance = \case
    DeriveConstants  -> context Stage0 deriveConstants
    GenApply         -> context Stage0 genapply
    GenPrimopCode    -> context Stage0 genprimopcode
    Ghc _ Stage0     -> Nothing
    Ghc _ stage      -> context (pred stage) ghc
    GhcPkg _ Stage0  -> Nothing
155
156
    GhcPkg _ s       -> context (pred s) ghcPkg
    Haddock _        -> context Stage1 haddock
157
    Hpc              -> context Stage1 hpcBin
158
    Hp2Ps            -> context Stage0 hp2ps
159
    Hsc2Hs _         -> context Stage0 hsc2hs
160
161
162
163
164
    Unlit            -> context Stage0 unlit
    _                -> Nothing
  where
    context s p = Just $ vanillaContext s p

165
166
167
168
169
170
instance H.Builder Builder where
    builderPath :: Builder -> Action FilePath
    builderPath builder = case builderProvenance builder of
        Nothing      -> systemBuilderPath builder
        Just context -> programPath context

171
172
    runtimeDependencies :: Builder -> Action [FilePath]
    runtimeDependencies = \case
173
        Autoreconf dir -> return [dir -/- "configure.ac"]
174
        Configure  dir -> return [dir -/- "configure"]
175

176
        Ghc _ Stage0 -> generatedGhcDependencies Stage0
177
178
        Ghc _ stage -> do
            root <- buildRoot
179
180
            win <- windowsHost
            touchyPath <- programPath (vanillaContext Stage0 touchy)
181
            unlitPath  <- builderPath Unlit
182
            ghcdeps <- ghcDeps stage
183
            ghcgens <- generatedGhcDependencies stage
184
            return $ [ root -/- ghcSplitPath stage -- TODO: Make conditional on --split-objects
185
                     , unlitPath ]
186
                  ++ ghcdeps
187
                  ++ ghcgens
188
189
                  ++ [ touchyPath | win ]

190
        Hsc2Hs stage -> (\p -> [p]) <$> templateHscPath stage
191
        Make dir  -> return [dir -/- "Makefile"]
192
        Haddock _ -> haddockDeps Stage1  -- Haddock currently runs in Stage1
193
        _         -> return []
194

195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
    -- query the builder for some information.
    -- contrast this with runBuilderWith, which returns @Action ()@
    -- this returns the @stdout@ from running the builder.
    -- For now this only implements asking @ghc-pkg@ about package
    -- dependencies.
    askBuilderWith :: Builder -> BuildInfo -> Action String
    askBuilderWith builder BuildInfo {..} = case builder of
        GhcPkg Dependencies _ -> do
            let input  = fromSingleton msgIn buildInputs
                msgIn  = "[askBuilder] Exactly one input file expected."
            needBuilder builder
            path <- H.builderPath builder
            need [path]
            Stdout stdout <- cmd [path] ["--no-user-package-db", "field", input, "depends"]
            return stdout
        _ -> error $ "Builder " ++ show builder ++ " can not be asked!"

212
213
214
215
    runBuilderWith :: Builder -> BuildInfo -> Action ()
    runBuilderWith builder BuildInfo {..} = do
        path <- builderPath builder
        withResources buildResources $ do
216
            verbosity <- getVerbosity
217
218
219
220
            let input  = fromSingleton msgIn buildInputs
                msgIn  = "[runBuilderWith] Exactly one input file expected."
                output = fromSingleton msgOut buildOutputs
                msgOut = "[runBuilderWith] Exactly one output file expected."
221
222
223
                -- Suppress stdout depending on the Shake's verbosity setting.
                echo = EchoStdout (verbosity >= Loud)
                -- Capture stdout and write it to the output file.
224
225
226
227
                captureStdout = do
                    Stdout stdout <- cmd [path] buildArgs
                    writeFileChanged output stdout
            case builder of
228
229
230
231
232
233
                Ar Pack _ -> do
                    useTempFile <- flag ArSupportsAtFile
                    if useTempFile then runAr                path buildArgs
                                   else runArWithoutTempFile path buildArgs

                Ar Unpack _ -> cmd echo [Cwd output] [path] buildArgs
234

235
                Autoreconf dir -> cmd echo [Cwd dir] [path] buildArgs
236
                Configure  dir -> do
237
238
239
240
                    -- Inject /bin/bash into `libtool`, instead of /bin/sh,
                    -- otherwise Windows breaks. TODO: Figure out why.
                    bash <- bashPath
                    let env = AddEnv "CONFIG_SHELL" bash
241
                    cmd echo env [Cwd dir] ["sh", path] buildOptions buildArgs
242
243
244
245
246
247
248
249
250

                HsCpp    -> captureStdout
                GenApply -> captureStdout

                GenPrimopCode -> do
                    stdin <- readFile' input
                    Stdout stdout <- cmd (Stdin stdin) [path] buildArgs
                    writeFileChanged output stdout

251
                Make dir -> cmd echo path ["-C", dir] buildArgs
252

253
                Xelatex -> do
254
255
256
257
258
259
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] ["makeindex"] (input -<.> "idx")
                    unit $ cmd [Cwd output] [path]        buildArgs
                    unit $ cmd [Cwd output] [path]        buildArgs
260

261
                GhcPkg Copy _ -> do
262
263
264
265
266
267
268
269
                    Stdout pkgDesc <- cmd [path]
                      [ "--expand-pkgroot"
                      , "--no-user-package-db"
                      , "describe"
                      , input -- the package name
                      ]
                    cmd (Stdin pkgDesc) [path] (buildArgs ++ ["-"])

270
271
272
273
                GhcPkg Unregister _ -> do
                    Exit _ <- cmd echo [path] (buildArgs ++ [input])
                    return ()

274
                _  -> cmd echo [path] buildArgs
275

Andrey Mokhov's avatar
Andrey Mokhov committed
276
-- TODO: Some builders are required only on certain platforms. For example,
277
278
279
-- 'Objdump' is only required on OpenBSD and AIX. Add support for platform
-- specific optional builders as soon as we can reliably test this feature.
-- See https://github.com/snowleopard/hadrian/issues/211.
280
281
isOptional :: Builder -> Bool
isOptional = \case
Andrey Mokhov's avatar
Andrey Mokhov committed
282
    Objdump  -> True
283
    _        -> False
284
285
286
287
288

-- | Determine the location of a system 'Builder'.
systemBuilderPath :: Builder -> Action FilePath
systemBuilderPath builder = case builder of
    Alex            -> fromKey "alex"
289
290
    Ar _ Stage0     -> fromKey "system-ar"
    Ar _ _          -> fromKey "ar"
291
    Autoreconf _    -> stripExe =<< fromKey "autoreconf"
292
293
294
    Cc  _  Stage0   -> fromKey "system-cc"
    Cc  _  _        -> fromKey "cc"
    -- We can't ask configure for the path to configure!
295
    Configure _     -> return "configure"
296
297
298
299
    Ghc _  Stage0   -> fromKey "system-ghc"
    GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
    Happy           -> fromKey "happy"
    HsCpp           -> fromKey "hs-cpp"
300
    Ld _            -> fromKey "ld"
301
302
303
304
305
    Make _          -> fromKey "make"
    Nm              -> fromKey "nm"
    Objdump         -> fromKey "objdump"
    Patch           -> fromKey "patch"
    Perl            -> fromKey "perl"
306
    Python          -> fromKey "python"
307
    Ranlib          -> fromKey "ranlib"
308
    RunTest         -> fromKey "python"
309
310
311
    Sphinx _        -> fromKey "sphinx-build"
    Tar _           -> fromKey "tar"
    Xelatex         -> fromKey "xelatex"
312
313
314
315
316
317
318
319
320
321
322
323
    _               -> error $ "No entry for " ++ show builder ++ inCfg
  where
    inCfg = " in " ++ quote configFile ++ " file."
    fromKey key = do
        let unpack = fromMaybe . error $ "Cannot find path to builder "
                ++ quote key ++ inCfg ++ " Did you skip configure?"
        path <- unpack <$> lookupValue configFile key
        if null path
        then do
            unless (isOptional builder) . error $ "Non optional builder "
                ++ quote key ++ " is not specified" ++ inCfg
            return "" -- TODO: Use a safe interface.
324
325
326
327
328
329
330
        else do
            win <- windowsHost
            fullPath <- lookupInPath path
            case (win, hasExtension fullPath) of
                (False, _    ) -> return fullPath
                (True , True ) -> fixAbsolutePathOnWindows fullPath
                (True , False) -> fixAbsolutePathOnWindows fullPath <&> (<.> exe)
331

332
333
334
335
336
337
338
339
340
341
342
343
    -- Without this function, on Windows we can observe a bad builder path
    -- for 'autoreconf'. If the relevant system.config field is set to
    -- /usr/bin/autoreconf in the file, the path that we read
    -- is C:/msys64/usr/bin/autoreconf.exe. A standard msys2 set up happens
    -- to have an executable named 'autoreconf' there, without the 'exe'
    -- extension. Hence this function.
    stripExe s = do
        let sNoExt = dropExtension s
        exists <- doesFileExist s
        if exists then return s else return sNoExt


344
345
346
347
-- | Was the path to a given system 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . systemBuilderPath

348
349
350
351
352
353
354
-- | Apply a patch by executing the 'Patch' builder in a given directory.
applyPatch :: FilePath -> FilePath -> Action ()
applyPatch dir patch = do
    let file = dir -/- patch
    needBuilder Patch
    path <- builderPath Patch
    putBuild $ "| Apply patch " ++ file
355
    quietly $ cmd [Cwd dir, FileStdin file] [path, "-p0"]