Fix merge conflicts
[hadrian.git] / src / Settings.hs
1 module Settings (
2 getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
3 findKnownPackage, getPkgData, getPkgDataList, isLibrary, stagePackages,
4 builderPath, getBuilderPath, isSpecified, latestBuildStage, programPath,
5 programContext, integerLibraryName, destDir, stage1Only, buildDll0
6 ) where
7
8 import Hadrian.Oracles.KeyValue
9 import Hadrian.Oracles.Path
10
11 import Context
12 import CommandLine
13 import Expression
14 import Flavour
15 import GHC
16 import Oracles.PackageData
17 import Oracles.Setting
18 import {-# SOURCE #-} Settings.Default
19 import Settings.Flavours.Development
20 import Settings.Flavours.Performance
21 import Settings.Flavours.Profiled
22 import Settings.Flavours.Quick
23 import Settings.Flavours.Quickest
24 import UserSettings
25
26 getArgs :: Args
27 getArgs = expr flavour >>= args
28
29 getLibraryWays :: Ways
30 getLibraryWays = expr flavour >>= libraryWays
31
32 getRtsWays :: Ways
33 getRtsWays = expr flavour >>= rtsWays
34
35 getPackages :: Packages
36 getPackages = expr flavour >>= packages
37
38 stagePackages :: Stage -> Action [Package]
39 stagePackages stage = interpretInContext (stageContext stage) getPackages
40
41 getPkgData :: (FilePath -> PackageData) -> Expr String
42 getPkgData key = expr . pkgData . key =<< getBuildPath
43
44 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
45 getPkgDataList key = expr . pkgDataList . key =<< getBuildPath
46
47 hadrianFlavours :: [Flavour]
48 hadrianFlavours =
49 [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
50 , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour ]
51
52 flavour :: Action Flavour
53 flavour = do
54 flavourName <- fromMaybe "default" <$> cmdFlavour
55 let unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
56 flavours = hadrianFlavours ++ userFlavours
57 return $ fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
58
59 integerLibraryName :: Action String
60 integerLibraryName = pkgNameString <$> (integerLibrary =<< flavour)
61
62 programContext :: Stage -> Package -> Action Context
63 programContext stage pkg = do
64 profiled <- ghcProfiled <$> flavour
65 return $ if pkg == ghc && profiled && stage > Stage0
66 then Context stage pkg profiling
67 else vanillaContext stage pkg
68
69 -- TODO: switch to Set Package as the order of packages should not matter?
70 -- Otherwise we have to keep remembering to sort packages from time to time.
71 knownPackages :: [Package]
72 knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
73
74 -- TODO: Speed up? Switch to Set?
75 -- Note: this is slow but we keep it simple as there are just ~50 packages
76 findKnownPackage :: PackageName -> Maybe Package
77 findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
78
79 -- | Determine the location of a system 'Builder'.
80 systemBuilderPath :: Builder -> Action FilePath
81 systemBuilderPath builder = case builder of
82 Alex -> fromKey "alex"
83 Ar Stage0 -> fromKey "system-ar"
84 Ar _ -> fromKey "ar"
85 Cc _ Stage0 -> fromKey "system-cc"
86 Cc _ _ -> fromKey "cc"
87 -- We can't ask configure for the path to configure!
88 Configure _ -> return "sh configure"
89 Ghc _ Stage0 -> fromKey "system-ghc"
90 GhcPkg _ Stage0 -> fromKey "system-ghc-pkg"
91 Happy -> fromKey "happy"
92 HsColour -> fromKey "hscolour"
93 HsCpp -> fromKey "hs-cpp"
94 Ld -> fromKey "ld"
95 Make _ -> fromKey "make"
96 Nm -> fromKey "nm"
97 Objdump -> fromKey "objdump"
98 Patch -> fromKey "patch"
99 Perl -> fromKey "perl"
100 Ranlib -> fromKey "ranlib"
101 Tar -> fromKey "tar"
102 _ -> error $ "No system.config entry for " ++ show builder
103 where
104 fromKey key = do
105 let unpack = fromMaybe . error $ "Cannot find path to builder "
106 ++ quote key ++ " in system.config file. Did you skip configure?"
107 path <- unpack <$> lookupValue configFile key
108 if null path
109 then do
110 unless (isOptional builder) . error $ "Non optional builder "
111 ++ quote key ++ " is not specified in system.config file."
112 return "" -- TODO: Use a safe interface.
113 else fixAbsolutePathOnWindows =<< lookupInPath path
114
115 -- | Determine the location of a 'Builder'.
116 builderPath :: Builder -> Action FilePath
117 builderPath builder = case builderProvenance builder of
118 Nothing -> systemBuilderPath builder
119 Just context -> do
120 maybePath <- programPath context
121 let msg = error $ show builder ++ " is never built by Hadrian."
122 return $ fromMaybe msg maybePath
123
124 getBuilderPath :: Builder -> Expr FilePath
125 getBuilderPath = expr . builderPath
126
127 -- | Was the path to a given 'Builder' specified in configuration files?
128 isSpecified :: Builder -> Action Bool
129 isSpecified = fmap (not . null) . builderPath
130
131 -- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
132 -- Nothing if the package is never built.
133 latestBuildStage :: Package -> Action (Maybe Stage)
134 latestBuildStage pkg = do
135 stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
136 return $ if null stages then Nothing else Just $ maximum stages
137
138 -- | The 'FilePath' to a program executable in a given 'Context'.
139 programPath :: Context -> Action (Maybe FilePath)
140 programPath context@Context {..} = do
141 maybeLatest <- latestBuildStage package
142 path <- buildPath context
143 return $ do
144 install <- (\l -> l == stage || package == ghc) <$> maybeLatest
145 let installPath = if install then inplaceInstallPath package else path
146 return $ installPath -/- programName context <.> exe
147
148 -- TODO: Set this from command line
149 -- | Stage1Only flag.
150 stage1Only :: Bool
151 stage1Only = defaultStage1Only
152
153 -- TODO: Set this from command line
154 -- | Install's DESTDIR setting.
155 destDir :: FilePath
156 destDir = defaultDestDir
157
158 buildDll0 :: Context -> Action Bool
159 buildDll0 Context {..} = do
160 windows <- windowsHost
161 return $ windows && stage == Stage1 && package == compiler