Util.hs 4.03 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
module Settings.Util (
2
    -- Primitive settings elements
3
    arg, argPath, argM,
4
    argConfig, argStagedConfig, argConfigList, argStagedConfigList,
5
    appendCcArgs,
6
7
8
9
10
11
    -- argBuilderPath, argStagedBuilderPath,
    -- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
    -- argIncludeDirs, argDepIncludeDirs,
    -- argConcat, argConcatPath, argConcatSpace,
    -- argPairs, argPrefix, argPrefixPath,
    -- argPackageConstraints,
Andrey Mokhov's avatar
Andrey Mokhov committed
12
13
    ) where

14
import Util
15
import Stage
Andrey Mokhov's avatar
Andrey Mokhov committed
16
import Builder
17
import Oracles.Base
18
19
import Expression

20
-- A single argument.
21
arg :: String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
22
23
arg = append . return

24
25
26
27
-- A single path argument. The path gets unified.
argPath :: String -> Args
argPath = append . return . unifyPath

28
argM :: Action String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
29
argM = appendM . fmap return
30

31
argConfig :: String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
32
argConfig = appendM . fmap return . askConfig
33

34
argConfigList :: String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
35
argConfigList = appendM . fmap words . askConfig
36
37
38
39

stagedKey :: Stage -> String -> String
stagedKey stage key = key ++ "-stage" ++ show stage

40
argStagedConfig :: String -> Args
41
42
43
44
argStagedConfig key = do
    stage <- asks getStage
    argConfig (stagedKey stage key)

45
argStagedConfigList :: String -> Args
46
47
48
49
argStagedConfigList key = do
    stage <- asks getStage
    argConfigList (stagedKey stage key)

50
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
51
52
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
53
    stage <- asks getStage
54
    mconcat [ builder (Gcc stage) ? append xs
55
56
            , builder GhcCabal    ? appendSub "--configure-option=CFLAGS" xs
            , builder GhcCabal    ? appendSub "--gcc-options" xs ]
57

58
-- packageData :: Arity -> String -> Args
59
60
61
62
-- packageData arity key =
--     return $ EnvironmentParameter $ PackageData arity key Nothing Nothing

-- -- Accessing key value pairs from package-data.mk files
63
-- argPackageKey :: Args
64
65
-- argPackageKey = packageData Single "PACKAGE_KEY"

66
-- argPackageDeps :: Args
67
68
-- argPackageDeps = packageData Multiple "DEPS"

69
-- argPackageDepKeys :: Args
70
71
-- argPackageDepKeys = packageData Multiple "DEP_KEYS"

72
-- argSrcDirs :: Args
73
74
-- argSrcDirs = packageData Multiple "HS_SRC_DIRS"

75
-- argIncludeDirs :: Args
76
77
-- argIncludeDirs = packageData Multiple "INCLUDE_DIRS"

78
-- argDepIncludeDirs :: Args
79
80
-- argDepIncludeDirs = packageData Multiple "DEP_INCLUDE_DIRS_SINGLE_QUOTED"

81
-- argPackageConstraints :: Packages -> Args
82
83
84
-- argPackageConstraints = return . EnvironmentParameter . PackageConstraints

-- -- Concatenate arguments: arg1 ++ arg2 ++ ...
85
-- argConcat :: Args -> Args
86
87
88
-- argConcat = return . Fold Concat

-- -- </>-concatenate arguments: arg1 </> arg2 </> ...
89
-- argConcatPath :: Args -> Args
90
91
92
-- argConcatPath = return . Fold ConcatPath

-- -- Concatene arguments (space separated): arg1 ++ " " ++ arg2 ++ ...
93
-- argConcatSpace :: Args -> Args
94
95
96
-- argConcatSpace = return . Fold ConcatSpace

-- -- An ordered list of pairs of arguments: prefix |> arg1, prefix |> arg2, ...
97
-- argPairs :: String -> Args -> Args
98
99
100
-- argPairs prefix settings = settings >>= (arg prefix |>) . return

-- -- An ordered list of prefixed arguments: prefix ++ arg1, prefix ++ arg2, ...
101
-- argPrefix :: String -> Args -> Args
102
103
104
-- argPrefix prefix = fmap (Fold Concat . (arg prefix |>) . return)

-- -- An ordered list of prefixed arguments: prefix </> arg1, prefix </> arg2, ...
105
-- argPrefixPath :: String -> Args -> Args
106
-- argPrefixPath prefix = fmap (Fold ConcatPath . (arg prefix |>) . return)
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

-- TODO: do '-ticky' in all debug ways?
-- wayHcArgs :: Way -> Args
-- wayHcArgs (Way _ units) = args
--     [ if (Dynamic    `elem` units)
--       then args ["-fPIC", "-dynamic"]
--       else arg "-static"
--     , when (Threaded   `elem` units) $ arg "-optc-DTHREADED_RTS"
--     , when (Debug      `elem` units) $ arg "-optc-DDEBUG"
--     , when (Profiling  `elem` units) $ arg "-prof"
--     , when (Logging    `elem` units) $ arg "-eventlog"
--     , when (Parallel   `elem` units) $ arg "-parallel"
--     , when (GranSim    `elem` units) $ arg "-gransim"
--     , when (units == [Debug] || units == [Debug, Dynamic]) $
--       args ["-ticky", "-DTICKY_TICKY"] ]