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