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