11c44b4a17342e1721dfc40be43d719e1e09bdae
[hadrian.git] / src / Settings / Util.hs
1 module Settings.Util (
2 -- Primitive settings elements
3 arg, argM,
4 argSetting, argSettingList,
5 getFlag, getSetting, getSettingList,
6 getPkgData, getPkgDataList,
7 appendCcArgs,
8 needBuilder
9 -- argBuilderPath, argStagedBuilderPath,
10 -- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
11 -- argIncludeDirs, argDepIncludeDirs,
12 -- argConcat, argConcatPath, argConcatSpace,
13 -- argPairs, argPrefix, argPrefixPath,
14 -- argPackageConstraints,
15 ) where
16
17 import Builder
18 import Expression
19 import Oracles.Base
20 import Oracles.Flag
21 import Oracles.Setting
22 import Oracles.PackageData
23 import Settings.User
24 import Settings.TargetDirectory
25
26 -- A single argument.
27 arg :: String -> Args
28 arg = append . return
29
30 argM :: Action String -> Args
31 argM = appendM . fmap return
32
33 argSetting :: Setting -> Args
34 argSetting = argM . setting
35
36 argSettingList :: SettingList -> Args
37 argSettingList = appendM . settingList
38
39 getFlag :: Flag -> Expr Bool
40 getFlag = lift . flag
41
42 getSetting :: Setting -> Expr String
43 getSetting = lift . setting
44
45 getSettingList :: SettingList -> Expr [String]
46 getSettingList = lift . settingList
47
48 getPkgData :: (FilePath -> PackageData) -> Expr String
49 getPkgData key = do
50 stage <- getStage
51 pkg <- getPackage
52 lift . pkgData . key $ targetPath stage pkg
53
54 getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
55 getPkgDataList key = do
56 stage <- getStage
57 pkg <- getPackage
58 lift . pkgDataList . key $ targetPath stage pkg
59
60 -- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
61 appendCcArgs :: [String] -> Args
62 appendCcArgs xs = do
63 stage <- getStage
64 mconcat [ builder (Gcc stage) ? append xs
65 , builder GhcCabal ? appendSub "--configure-option=CFLAGS" xs
66 , builder GhcCabal ? appendSub "--gcc-options" xs ]
67
68 -- Make sure a builder exists on the given path and rebuild it if out of date.
69 -- If laxDependencies is true (Settings/User.hs) then we do not rebuild GHC
70 -- even if it is out of date (can save a lot of build time when changing GHC).
71 needBuilder :: Builder -> Action ()
72 needBuilder ghc @ (Ghc stage) = do
73 path <- builderPath ghc
74 if laxDependencies then orderOnly [path] else need [path]
75
76 needBuilder builder = do
77 path <- builderPath builder
78 need [path]
79
80
81
82 -- packageData :: Arity -> String -> Args
83 -- packageData arity key =
84 -- return $ EnvironmentParameter $ PackageData arity key Nothing Nothing
85
86 -- -- Accessing key value pairs from package-data.mk files
87 -- argPackageKey :: Args
88 -- argPackageKey = packageData Single "PACKAGE_KEY"
89
90 -- argPackageDeps :: Args
91 -- argPackageDeps = packageData Multiple "DEPS"
92
93 -- argPackageDepKeys :: Args
94 -- argPackageDepKeys = packageData Multiple "DEP_KEYS"
95
96 -- argSrcDirs :: Args
97 -- argSrcDirs = packageData Multiple "HS_SRC_DIRS"
98
99 -- argIncludeDirs :: Args
100 -- argIncludeDirs = packageData Multiple "INCLUDE_DIRS"
101
102 -- argDepIncludeDirs :: Args
103 -- argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"
104
105 -- argPackageConstraints :: Packages -> Args
106 -- argPackageConstraints = return . EnvironmentParameter . PackageConstraints
107
108 -- -- Concatenate arguments: arg1 ++ arg2 ++ ...
109 -- argConcat :: Args -> Args
110 -- argConcat = return . Fold Concat
111
112 -- -- </>-concatenate arguments: arg1 </> arg2 </> ...
113 -- argConcatPath :: Args -> Args
114 -- argConcatPath = return . Fold ConcatPath
115
116 -- -- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
117 -- argConcatSpace :: Args -> Args
118 -- argConcatSpace = return . Fold ConcatSpace
119
120 -- -- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
121 -- argPairs :: String -> Args -> Args
122 -- argPairs prefix settings = settings >>= (arg prefix |>) . return
123
124 -- -- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
125 -- argPrefix :: String -> Args -> Args
126 -- argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)
127
128 -- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
129 -- argPrefixPath :: String -> Args -> Args
130 -- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
131
132 -- TODO: do '-ticky' in all debug ways?
133 -- wayHcArgs :: Way -> Args
134 -- wayHcArgs (Way _ units) = args
135 -- [ if (Dynamic `elem` units)
136 -- then args ["-fPIC", "-dynamic"]
137 -- else arg "-static"
138 -- , when (Threaded `elem` units) $ arg "-optc-DTHREADED_RTS"
139 -- , when (Debug `elem` units) $ arg "-optc-DDEBUG"
140 -- , when (Profiling `elem` units) $ arg "-prof"
141 -- , when (Logging `elem` units) $ arg "-eventlog"
142 -- , when (Parallel `elem` units) $ arg "-parallel"
143 -- , when (GranSim `elem` units) $ arg "-gransim"
144 -- , when (units == [Debug] || units == [Debug, Dynamic]) $
145 -- args ["-ticky", "-DTICKY_TICKY"] ]