Util.hs 4.13 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
module Settings.Util (
2
    -- Primitive settings elements
3
    arg, argM,
4
    argSetting, argSettingList,
5
    getFlag, getSetting, getSettingList,
6
    getPkgData, getPkgDataList,
Andrey Mokhov's avatar
Andrey Mokhov committed
7
    getPackagePath, getTargetPath, getTargetDirectory,
Andrey Mokhov's avatar
Andrey Mokhov committed
8
    getHsSources, getSourceFiles,
9
    appendCcArgs,
10
    needBuilder
11 12 13 14 15 16
    -- argBuilderPath, argStagedBuilderPath,
    -- argPackageKey, argPackageDeps, argPackageDepKeys, argSrcDirs,
    -- argIncludeDirs, argDepIncludeDirs,
    -- argConcat, argConcatPath, argConcatSpace,
    -- argPairs, argPrefix, argPrefixPath,
    -- argPackageConstraints,
Andrey Mokhov's avatar
Andrey Mokhov committed
17 18
    ) where

Andrey Mokhov's avatar
Andrey Mokhov committed
19
import Util
Andrey Mokhov's avatar
Andrey Mokhov committed
20
import Builder
Andrey Mokhov's avatar
Andrey Mokhov committed
21
import Package
22
import Expression
23
import Oracles.Base
24
import Oracles.Flag
25
import Oracles.Setting
26
import Oracles.PackageData
27
import Settings.User
28
import Settings.TargetDirectory
29

30
-- A single argument.
31
arg :: String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
32 33
arg = append . return

34
argM :: Action String -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
35
argM = appendM . fmap return
36

37 38
argSetting :: Setting -> Args
argSetting = argM . setting
39

40 41
argSettingList :: SettingList -> Args
argSettingList = appendM . settingList
42

43 44 45 46 47 48 49 50 51
getFlag :: Flag -> Expr Bool
getFlag = lift . flag

getSetting :: Setting -> Expr String
getSetting = lift . setting

getSettingList :: SettingList -> Expr [String]
getSettingList = lift . settingList

52 53
getPkgData :: (FilePath -> PackageData) -> Expr String
getPkgData key = do
54 55 56
    stage <- getStage
    pkg   <- getPackage
    lift . pkgData . key $ targetPath stage pkg
57

58 59
getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
getPkgDataList key = do
60 61 62
    stage <- getStage
    pkg   <- getPackage
    lift . pkgDataList . key $ targetPath stage pkg
63

Andrey Mokhov's avatar
Andrey Mokhov committed
64 65 66 67 68 69 70 71 72
getPackagePath :: Expr FilePath
getPackagePath = liftM pkgPath getPackage

getTargetPath :: Expr FilePath
getTargetPath = liftM2 targetPath getStage getPackage

getTargetDirectory :: Expr FilePath
getTargetDirectory = liftM2 targetDirectory getStage getPackage

Andrey Mokhov's avatar
Andrey Mokhov committed
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
-- Find all Haskell source files for the current target
getHsSources :: Expr [FilePath]
getHsSources = do
    path    <- getTargetPath
    pkgPath <- getPackagePath
    srcDirs <- getPkgDataList SrcDirs
    let paths = (path -/- "build/autogen") : map (pkgPath -/-) srcDirs
    getSourceFiles paths [".hs", ".lhs"]

-- Find all source files in specified paths and with given extensions
getSourceFiles :: [FilePath] -> [String] -> Expr [FilePath]
getSourceFiles paths exts = do
    modules <- getPkgDataList Modules
    let modPaths   = map (replaceEq '.' '/') modules
        candidates = [ p -/- m ++ e | p <- paths, m <- modPaths, e <- exts ]
    files <- lift $ filterM (doesDirectoryExist . takeDirectory) candidates
    result <- lift $ getDirectoryFiles "" files
    return $ map unifyPath result

92
-- Pass arguments to Gcc and corresponding lists of sub-arguments of GhcCabal
93 94
appendCcArgs :: [String] -> Args
appendCcArgs xs = do
95
    stage <- getStage
96 97 98 99
    mconcat [ builder (Gcc stage)  ? append xs
            , builder (GccM stage) ? append xs
            , builder GhcCabal     ? appendSub "--configure-option=CFLAGS" xs
            , builder GhcCabal     ? appendSub "--gcc-options" xs ]
100

101 102 103 104 105 106 107 108 109 110 111 112
-- Make sure a builder exists on the given path and rebuild it if out of date.
-- If laxDependencies is true (Settings/User.hs) then we do not rebuild GHC
-- even if it is out of date (can save a lot of build time when changing GHC).
needBuilder :: Builder -> Action ()
needBuilder ghc @ (Ghc stage) = do
    path <- builderPath ghc
    if laxDependencies then orderOnly [path] else need [path]

needBuilder builder = do
    path <- builderPath builder
    need [path]

113 114 115 116 117 118 119 120 121 122 123 124 125 126
-- 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"] ]