913878035a24b4712c8a0be88b536c40b3d64547
[hadrian.git] / src / Oracles.hs
1 {-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-}
2 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveGeneric, ConstraintKinds #-}
3
4 module Oracles (
5 module Control.Monad,
6 module Development.Shake.Rule,
7 module Prelude,
8 Builder (..), Flag (..), Option (..),
9 path, with, run, argPath,
10 option, argOption,
11 test, when, unless, not, (&&), (||),
12 oracleRules
13 ) where
14
15 import Development.Shake.Config
16 import Development.Shake.Rule
17 import Development.Shake.Classes
18 import Control.Monad hiding (when, unless)
19 import qualified System.Directory as System
20 import qualified Data.HashMap.Strict as M
21 import qualified Prelude
22 import Prelude hiding (not, (&&), (||))
23 import Base
24
25 data Builder = Ar | Ld | Gcc | Alex | Happy | HsColour | GhcCabal | GhcPkg Stage | Ghc Stage
26
27 path :: Builder -> Action FilePath
28 path builder = do
29 let key = case builder of
30 Ar -> "ar"
31 Ld -> "ld"
32 Gcc -> "gcc"
33 Alex -> "alex"
34 Happy -> "happy"
35 HsColour -> "hscolour"
36 GhcCabal -> "ghc-cabal"
37 Ghc Stage0 -> "system-ghc" -- Ghc Stage0 is the bootstrapping compiler
38 Ghc Stage1 -> "ghc-stage1" -- Ghc StageN, N > 0, is the one built on stage (N - 1)
39 Ghc Stage2 -> "ghc-stage2"
40 Ghc Stage3 -> "ghc-stage3"
41 GhcPkg Stage0 -> "system-ghc-pkg" -- GhcPkg Stage0 is the bootstrapping GhcPkg
42 GhcPkg _ -> "ghc-pkg" -- GhcPkg StageN, N > 0, is the one built on stage 0 (TODO: need only Stage1?)
43 askConfigWithDefault key $
44 error $ "\nCannot find path to '"
45 ++ key
46 ++ "' in configuration files."
47
48 argPath :: Builder -> Args
49 argPath builder = do
50 path <- path builder
51 arg [path]
52
53 -- Explain!
54 -- TODO: document change in behaviour (LaxDeps)
55 needBuilder :: Builder -> Action ()
56 needBuilder ghc @ (Ghc _) = do
57 target <- path ghc
58 laxDeps <- test LaxDeps -- TODO: get rid of test?
59 if laxDeps then orderOnly [target] else need [target]
60
61 needBuilder builder = do
62 target <- path builder
63 need [target]
64
65 -- 'with Gcc' generates --with-gcc=/usr/bin/gcc and needs it
66 with :: Builder -> Args
67 with builder = do
68 let prefix = case builder of
69 Ar -> "--with-ar="
70 Ld -> "--with-ld="
71 Gcc -> "--with-gcc="
72 Ghc _ -> "--with-ghc="
73 Alex -> "--with-alex="
74 Happy -> "--with-happy="
75 GhcPkg _ -> "--with-ghc-pkg="
76 HsColour -> "--with-hscolour="
77 suffix <- path builder
78 needBuilder builder
79 return [prefix ++ suffix]
80
81 run :: Builder -> Args -> Action ()
82 run builder args = do
83 needBuilder builder
84 exe <- path builder
85 args' <- args
86 cmd [exe :: FilePath] args'
87
88 data Option = TargetOS | TargetArch | TargetPlatformFull
89 | ConfCcArgs Stage | ConfGccLinkerArgs Stage | ConfLdLinkerArgs Stage | ConfCppArgs Stage
90 | IconvIncludeDirs | IconvLibDirs | GmpIncludeDirs | GmpLibDirs
91 | HostOsCpp
92
93 option :: Option -> Action String
94 option opt = askConfig $ case opt of
95 TargetOS -> "target-os"
96 TargetArch -> "target-arch"
97 TargetPlatformFull -> "target-platform-full"
98 ConfCcArgs stage -> "conf-cc-args-stage-" ++ (show . fromEnum) stage
99 ConfCppArgs stage -> "conf-cpp-args-stage-" ++ (show . fromEnum) stage
100 ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage-" ++ (show . fromEnum) stage
101 ConfLdLinkerArgs stage -> "conf-ld-linker-args-stage-" ++ (show . fromEnum) stage
102 IconvIncludeDirs -> "iconv-include-dirs"
103 IconvLibDirs -> "iconv-lib-dirs"
104 GmpIncludeDirs -> "gmp-include-dirs"
105 GmpLibDirs -> "gmp-lib-dirs"
106 HostOsCpp -> "host-os-cpp"
107
108 argOption :: Option -> Args
109 argOption opt = do
110 opt' <- option opt
111 arg [opt']
112
113 data Flag = LaxDeps | Stage1Only | DynamicGhcPrograms | GhcWithInterpreter | HsColourSrcs
114 | GccIsClang | GccLt46 | CrossCompiling | Validating | PlatformSupportsSharedLibs
115
116 test :: Flag -> Action Bool
117 test GhcWithInterpreter = do
118 os <- option TargetOS
119 arch <- option TargetArch
120 return $
121 os `elem` ["mingw32", "cygwin32", "linux", "solaris2", "freebsd", "dragonfly", "netbsd", "openbsd", "darwin", "kfreebsdgnu"]
122 &&
123 arch `elem` ["i386", "x86_64", "powerpc", "sparc", "sparc64", "arm"]
124
125 test PlatformSupportsSharedLibs = do
126 platform <- option TargetPlatformFull
127 return $ platform `notElem` [ "powerpc-unknown-linux", "x86_64-unknown-mingw32", "i386-unknown-mingw32" ] -- TODO: i386-unknown-solaris2?
128
129 test HsColourSrcs = do
130 hscolour <- path HsColour
131 return $ hscolour /= ""
132
133 test flag = do
134 (key, defaultValue) <- return $ case flag of
135 LaxDeps -> ("lax-dependencies" , False) -- TODO: move flags to a separate file
136 Stage1Only -> ("stage-1-only" , False) -- TODO: target only
137 DynamicGhcPrograms -> ("dynamic-ghc-programs", False)
138 GccIsClang -> ("gcc-is-clang" , False)
139 GccLt46 -> ("gcc-lt-46" , False)
140 CrossCompiling -> ("cross-compiling" , False)
141 Validating -> ("validating" , False)
142 let defaultString = if defaultValue then "YES" else "NO"
143 value <- askConfigWithDefault key $
144 do putLoud $ "\nFlag '"
145 ++ key
146 ++ "' not set in configuration files. "
147 ++ "Proceeding with default value '"
148 ++ defaultString
149 ++ "'.\n"
150 return defaultString
151 return $ value == "YES"
152
153 class ToCondition a where
154 toCondition :: a -> Condition
155
156 instance ToCondition Condition where
157 toCondition = id
158
159 instance ToCondition Bool where
160 toCondition = return
161
162 instance ToCondition Flag where
163 toCondition = test
164
165 when :: (ToCondition a, Monoid m) => a -> Action m -> Action m
166 when x args = do
167 bool <- toCondition x
168 if bool then args else mempty
169
170 unless :: (ToCondition a, Monoid m) => a -> Action m -> Action m
171 unless x args = do
172 bool <- toCondition x
173 if bool then mempty else args
174
175 class Not a where
176 type NotResult a
177 not :: a -> NotResult a
178
179 instance Not Bool where
180 type NotResult Bool = Bool
181 not = Prelude.not
182
183 instance Not Condition where
184 type NotResult Condition = Condition
185 not x = not <$> (toCondition x)
186
187 instance Not Flag where
188 type NotResult Flag = Condition
189 not x = not (toCondition x)
190
191 class AndOr a b where
192 type AndOrResult a b
193 (&&) :: a -> b -> AndOrResult a b
194 (||) :: a -> b -> AndOrResult a b
195
196 infixr 3 &&
197 infixr 2 ||
198
199 instance AndOr Bool Bool where
200 type AndOrResult Bool Bool = Bool
201 (&&) = (Prelude.&&)
202 (||) = (Prelude.||)
203
204 instance ToCondition a => AndOr Condition a where
205 type AndOrResult Condition a = Condition
206 x && y = (Prelude.&&) <$> toCondition x <*> toCondition y
207 x || y = (Prelude.||) <$> toCondition x <*> toCondition y
208
209 instance ToCondition a => AndOr Flag a where
210 type AndOrResult Flag a = Condition
211 x && y = toCondition x && y
212 x || y = toCondition x || y
213
214 newtype ConfigKey = ConfigKey String deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
215
216 askConfigWithDefault :: String -> Action String -> Action String
217 askConfigWithDefault key defaultAction = do
218 maybeValue <- askOracle $ ConfigKey $ key
219 case maybeValue of
220 Just value -> return value
221 Nothing -> do
222 result <- defaultAction
223 return result
224
225 askConfig :: String -> Action String
226 askConfig key = askConfigWithDefault key $ error $ "\nCannot find key '"
227 ++ key
228 ++ "' in configuration files."
229
230 oracleRules :: Rules ()
231 oracleRules = do
232 cfg <- newCache $ \() -> do
233 unless (doesFileExist "shake/default.config") $ do
234 error $ "\nDefault configuration file '"
235 ++ "shake/default.config.in"
236 ++ "' is missing; unwilling to proceed."
237 return ()
238 need ["shake/default.config"]
239 cfgDefault <- liftIO $ readConfigFile "shake/default.config"
240 existsUser <- doesFileExist "shake/user.config"
241 cfgUser <- if existsUser
242 then liftIO $ readConfigFile "shake/user.config"
243 else do
244 putLoud $ "\nUser defined configuration file '"
245 ++ "shake/user.config"
246 ++ "' is missing; proceeding with default configuration.\n"
247 return M.empty
248 return $ cfgUser `M.union` cfgDefault
249 addOracle $ \(ConfigKey x) -> M.lookup x <$> cfg ()
250 return ()