Refactor programPath
[hadrian.git] / src / Settings.hs
1 module Settings (
2 getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
3 findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
4 getContextDirectory, getBuildPath, stagePackages, builderPath,
5 getBuilderPath, isSpecified, latestBuildStage, programPath
6 ) where
7
8 import Base
9 import Context
10 import CmdLineFlag
11 import Expression
12 import Flavour
13 import GHC
14 import Oracles.PackageData
15 import Oracles.Path
16 import {-# SOURCE #-} Settings.Default
17 import Settings.Flavours.Quick
18 import Settings.Flavours.Quickest
19 import Settings.Path
20 import UserSettings
21
22 getArgs :: Expr [String]
23 getArgs = fromDiffExpr $ args flavour
24
25 getLibraryWays :: Expr [Way]
26 getLibraryWays = fromDiffExpr $ libraryWays flavour
27
28 getRtsWays :: Expr [Way]
29 getRtsWays = fromDiffExpr $ rtsWays flavour
30
31 getPackages :: Expr [Package]
32 getPackages = fromDiffExpr $ packages flavour
33
34 stagePackages :: Stage -> Action [Package]
35 stagePackages stage = interpretInContext (stageContext stage) getPackages
36
37 getPackagePath :: Expr FilePath
38 getPackagePath = pkgPath <$> getPackage
39
40 getContextDirectory :: Expr FilePath
41 getContextDirectory = stageDirectory <$> getStage
42
43 getBuildPath :: Expr FilePath
44 getBuildPath = buildPath <$> getContext
45
46 getPkgData :: (FilePath -> PackageData) -> Expr String
47 getPkgData key = lift . pkgData . key =<< getBuildPath
48
49 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
50 getPkgDataList key = lift . pkgDataList . key =<< getBuildPath
51
52 hadrianFlavours :: [Flavour]
53 hadrianFlavours = [defaultFlavour, quickFlavour, quickestFlavour]
54
55 flavour :: Flavour
56 flavour = fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
57 where
58 unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
59 flavours = hadrianFlavours ++ userFlavours
60 flavourName = fromMaybe "default" cmdFlavour
61
62 -- TODO: switch to Set Package as the order of packages should not matter?
63 -- Otherwise we have to keep remembering to sort packages from time to time.
64 knownPackages :: [Package]
65 knownPackages = sort $ defaultKnownPackages ++ userKnownPackages
66
67 -- TODO: Speed up?
68 -- Note: this is slow but we keep it simple as there are just ~50 packages
69 findKnownPackage :: PackageName -> Maybe Package
70 findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages
71
72 -- | Determine the location of a 'Builder'.
73 builderPath :: Builder -> Action FilePath
74 builderPath builder = case builderProvenance builder of
75 Nothing -> systemBuilderPath builder
76 Just context -> do
77 maybePath <- programPath context
78 let msg = error $ show builder ++ " is never built by Hadrian."
79 return $ fromMaybe msg maybePath
80
81 getBuilderPath :: Builder -> ReaderT a Action FilePath
82 getBuilderPath = lift . builderPath
83
84 -- | Was the path to a given 'Builder' specified in configuration files?
85 isSpecified :: Builder -> Action Bool
86 isSpecified = fmap (not . null) . builderPath
87
88 -- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
89 -- Nothing if the package is never built.
90 latestBuildStage :: Package -> Action (Maybe Stage)
91 latestBuildStage pkg = do
92 stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
93 return $ if null stages then Nothing else Just $ maximum stages
94
95 -- | The 'FilePath' to a program executable in a given 'Context'.
96 programPath :: Context -> Action (Maybe FilePath)
97 programPath context@Context {..} = do
98 maybeLatest <- latestBuildStage package
99 return $ do
100 install <- (\l -> l == stage || package == ghc) <$> maybeLatest
101 let path = if install then installPath package else buildPath context
102 return $ path -/- programName context <.> exe