1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
{-# LANGUAGE CPP #-}
module Main (main) where
import Development.Shake
import Hadrian.Utilities
import Settings.Parser
import System.Directory (getCurrentDirectory)
import System.IO
import System.Exit
import System.Environment
import Control.Exception
import Data.IORef
import qualified Base
import qualified CommandLine
import qualified Environment
import qualified Rules
import qualified Rules.Clean
import qualified Rules.Docspec
import qualified Rules.Documentation
import qualified Rules.Lint
import qualified Rules.Nofib
#if HADRIAN_ENABLE_SELFTEST
import qualified Rules.Selftest
#endif
import qualified Rules.SourceDist
import qualified Rules.Test
import qualified UserSettings
main :: IO ()
main = do
-- Provide access to command line arguments and some user settings through
-- Shake's type-indexed map 'shakeExtra'.
argsMap <- CommandLine.cmdLineArgsMap
let extra = insertExtra UserSettings.buildProgressColour
$ insertExtra UserSettings.successColour
$ argsMap
BuildRoot buildRoot = CommandLine.lookupBuildRoot argsMap
rebuild = [ (RebuildLater, buildRoot -/- "stage0/**")
| CommandLine.lookupFreeze1 argsMap ||
CommandLine.lookupFreeze2 argsMap
] ++
[ (RebuildLater, buildRoot -/- "stage1/**")
| CommandLine.lookupFreeze2 argsMap
] ++
(if CommandLine.lookupSkipDepends argsMap
then [(RebuildLater, buildRoot -/- "**/.dependencies.mk"), (RebuildLater, buildRoot -/- "**/.dependencies")]
else [])
cwd <- getCurrentDirectory
shakeColor <- shouldUseColor
let options :: ShakeOptions
options = shakeOptions
{ shakeChange = ChangeModtimeAndDigest
, shakeFiles = buildRoot -/- Base.shakeFilesDir
, shakeProgress = progressSimple
, shakeRebuild = rebuild
, shakeTimings = False
, shakeColor = shakeColor
, shakeExtra = extra
-- Setting shakeSymlink to False ensures files are copied out of
-- shake's cloud cache instead of hard linked. This is important as
-- the hard link mode makes all such files read only to avoid
-- accidentally modifying cache files via the hard link. It turns
-- out, many Hadrian rules attempt read access to such files and
-- hence would in the hard link mode. These rules could be
-- refactored to avoid write access, but setting shakeSymlink to
-- False is a much simpler solution.
, shakeSymlink = False
-- Enable linting file accesses in the build dir and ghc root dir
-- (cwd) when using the `--lint-fsatrace` option.
, shakeLintInside = [ cwd, buildRoot ]
, shakeLintIgnore =
-- Ignore access to the package database caches.
-- They are managed externally by the ghc-pkg tool.
[ buildRoot -/- "**/package.conf.d/package.cache"
-- Ignore access to autom4te.cache directories.
-- They are managed externally by auto tools.
, "//autom4te.cache/**"
-- Ignore in-tree GMP objects
, buildRoot -/- "**/gmp/objs/**"
]
, shakeOutput = \v -> case v of
-- We don't want to print internal shake diagnostic messages as
-- they are too verbose to be of any use. See #20484.
Diagnostic -> const (pure ())
_ -> shakeOutput shakeOptions v
}
rules :: Rules ()
rules = do
Rules.buildRules
Rules.Docspec.docspecRules
Rules.Documentation.documentationRules
Rules.Clean.cleanRules
Rules.Lint.lintRules
Rules.Nofib.nofibRules
Rules.oracleRules
#if HADRIAN_ENABLE_SELFTEST
Rules.Selftest.selftestRules
#endif
Rules.SourceDist.sourceDistRules
Rules.Test.testRules
Rules.topLevelTargets
Rules.toolArgsTarget
-- This IORef is used to communicate the result of shake parsing
-- command line options (which happens in shakeArgsOptionsWith, but
-- isn't exposed to the user) to the exception handler, which uses the
-- verbosity and colour information to decide how much of the error to display.
shake_opts_var <- newIORef options
handleShakeException shake_opts_var $ shakeArgsOptionsWith options CommandLine.optDescrs $ \shake_opts _ targets -> do
writeIORef shake_opts_var shake_opts
let targets' = filter (not . null) $ removeKVs targets
Environment.setupEnvironment
return . Just $ (shake_opts, if null targets'
then rules
else want targets' >> withoutActions rules)
handleShakeException :: IORef ShakeOptions -> IO a -> IO a
handleShakeException shake_opts_var shake_run = do
args <- getArgs
-- Using withArgs here is a bit of a hack but the API doesn't allow another way
-- See https://github.com/ndmitchell/shake/issues/811
-- Passing --exception means shake throws an exception rather than
-- catching ShakeException and displaying the error itself to the user.
catch (withArgs ("--exception" : args) $ shake_run) $ \(_e :: ShakeException) -> do
shake_opts <- readIORef shake_opts_var
let
FailureColour col = lookupExtra red (shakeExtra shake_opts)
esc = if shakeColor shake_opts then escape col else id
if shakeVerbosity shake_opts >= Verbose
then
hPrint stderr _e
else
-- The SomeException here is normally an IOError which lacks
-- very much structure, in the future we could try to catch
-- a more structured exception and further refine the
-- displayed output. https://github.com/ndmitchell/shake/pull/812
hPrint stderr (shakeExceptionInner _e)
hPutStrLn stderr (esc "Build failed.")
exitFailure
escForeground :: String -> String
escForeground code = "\ESC[" ++ code ++ "m"
escNormal :: String
escNormal = "\ESC[0m"
escape :: String -> String -> String
escape code x = escForeground code ++ x ++ escNormal
|
