Settings.hs 4.44 KB
Newer Older
1
module Settings (
Andrey Mokhov's avatar
Andrey Mokhov committed
2 3
    getArgs, getPackages, getLibraryWays, getRtsWays, flavour, knownPackages,
    findKnownPackage, getPkgData, getPkgDataList, isLibrary, getPackagePath,
Andrey Mokhov's avatar
Andrey Mokhov committed
4
    getContextDirectory, getBuildPath, stagePackages, builderPath,
Andrey Mokhov's avatar
Andrey Mokhov committed
5
    getBuilderPath, isSpecified, latestBuildStage, programPath, programContext,
Zhen Zhang's avatar
Zhen Zhang committed
6
    integerLibraryName, destDir, pkgConfInstallPath, stage1Only
7 8
    ) where

Ben Gamari's avatar
Ben Gamari committed
9
import Base
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Context
Andrey Mokhov's avatar
Andrey Mokhov committed
11
import CmdLineFlag
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import Expression
Andrey Mokhov's avatar
Andrey Mokhov committed
13 14
import Flavour
import GHC
Andrey Mokhov's avatar
Andrey Mokhov committed
15
import Oracles.PackageData
Andrey Mokhov's avatar
Andrey Mokhov committed
16
import Oracles.Path
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import {-# SOURCE #-} Settings.Default
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import Settings.Flavours.Development
Andrey Mokhov's avatar
Andrey Mokhov committed
19 20
import Settings.Flavours.Performance
import Settings.Flavours.Profiled
Andrey Mokhov's avatar
Andrey Mokhov committed
21 22
import Settings.Flavours.Quick
import Settings.Flavours.Quickest
23
import Settings.Path
24
import UserSettings
Andrey Mokhov's avatar
Andrey Mokhov committed
25

Andrey Mokhov's avatar
Andrey Mokhov committed
26
getArgs :: Expr [String]
27
getArgs = args flavour
Andrey Mokhov's avatar
Andrey Mokhov committed
28 29

getLibraryWays :: Expr [Way]
30
getLibraryWays = libraryWays flavour
Andrey Mokhov's avatar
Andrey Mokhov committed
31 32

getRtsWays :: Expr [Way]
33
getRtsWays = rtsWays flavour
Andrey Mokhov's avatar
Andrey Mokhov committed
34 35

getPackages :: Expr [Package]
36
getPackages = packages flavour
Andrey Mokhov's avatar
Andrey Mokhov committed
37

38 39 40
stagePackages :: Stage -> Action [Package]
stagePackages stage = interpretInContext (stageContext stage) getPackages

Andrey Mokhov's avatar
Andrey Mokhov committed
41
getPackagePath :: Expr FilePath
Ben Gamari's avatar
Ben Gamari committed
42
getPackagePath = pkgPath <$> getPackage
Andrey Mokhov's avatar
Andrey Mokhov committed
43

Andrey Mokhov's avatar
Andrey Mokhov committed
44
getContextDirectory :: Expr FilePath
45
getContextDirectory = stageDirectory <$> getStage
Andrey Mokhov's avatar
Andrey Mokhov committed
46

47 48
getBuildPath :: Expr FilePath
getBuildPath = buildPath <$> getContext
Andrey Mokhov's avatar
Andrey Mokhov committed
49 50

getPkgData :: (FilePath -> PackageData) -> Expr String
51
getPkgData key = expr . pkgData . key =<< getBuildPath
Andrey Mokhov's avatar
Andrey Mokhov committed
52 53

getPkgDataList :: (FilePath -> PackageDataList) -> Expr [String]
54
getPkgDataList key = expr . pkgDataList . key =<< getBuildPath
Andrey Mokhov's avatar
Andrey Mokhov committed
55

Andrey Mokhov's avatar
Andrey Mokhov committed
56
hadrianFlavours :: [Flavour]
Andrey Mokhov's avatar
Andrey Mokhov committed
57 58
hadrianFlavours =
    [ defaultFlavour, developmentFlavour Stage1, developmentFlavour Stage2
Andrey Mokhov's avatar
Andrey Mokhov committed
59
    , performanceFlavour, profiledFlavour, quickFlavour, quickestFlavour ]
Andrey Mokhov's avatar
Andrey Mokhov committed
60 61 62 63 64 65 66 67

flavour :: Flavour
flavour = fromMaybe unknownFlavour $ find ((== flavourName) . name) flavours
  where
    unknownFlavour = error $ "Unknown build flavour: " ++ flavourName
    flavours       = hadrianFlavours ++ userFlavours
    flavourName    = fromMaybe "default" cmdFlavour

Andrey Mokhov's avatar
Andrey Mokhov committed
68 69 70
integerLibraryName :: String
integerLibraryName = pkgNameString $ integerLibrary flavour

Andrey Mokhov's avatar
Andrey Mokhov committed
71 72
programContext :: Stage -> Package -> Context
programContext stage pkg
Andrey Mokhov's avatar
Andrey Mokhov committed
73
    | pkg == ghc && ghcProfiled flavour && stage > Stage0 = Context stage pkg profiling
Andrey Mokhov's avatar
Andrey Mokhov committed
74 75
    | otherwise = vanillaContext stage pkg

Andrey Mokhov's avatar
Andrey Mokhov committed
76 77 78 79 80 81 82 83 84 85
-- TODO: switch to Set Package as the order of packages should not matter?
-- Otherwise we have to keep remembering to sort packages from time to time.
knownPackages :: [Package]
knownPackages = sort $ defaultKnownPackages ++ userKnownPackages

-- TODO: Speed up?
-- Note: this is slow but we keep it simple as there are just ~50 packages
findKnownPackage :: PackageName -> Maybe Package
findKnownPackage name = find (\pkg -> pkgName pkg == name) knownPackages

Andrey Mokhov's avatar
Andrey Mokhov committed
86 87 88 89 90 91 92 93 94
-- | Determine the location of a 'Builder'.
builderPath :: Builder -> Action FilePath
builderPath builder = case builderProvenance builder of
    Nothing      -> systemBuilderPath builder
    Just context -> do
        maybePath <- programPath context
        let msg = error $ show builder ++ " is never built by Hadrian."
        return $ fromMaybe msg maybePath

95 96
getBuilderPath :: Builder -> Expr FilePath
getBuilderPath = expr . builderPath
Andrey Mokhov's avatar
Andrey Mokhov committed
97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114

-- | Was the path to a given 'Builder' specified in configuration files?
isSpecified :: Builder -> Action Bool
isSpecified = fmap (not . null) . builderPath

-- | Determine the latest 'Stage' in which a given 'Package' is built. Returns
-- Nothing if the package is never built.
latestBuildStage :: Package -> Action (Maybe Stage)
latestBuildStage pkg = do
    stages <- filterM (fmap (pkg `elem`) . stagePackages) [Stage0 ..]
    return $ if null stages then Nothing else Just $ maximum stages

-- | The 'FilePath' to a program executable in a given 'Context'.
programPath :: Context -> Action (Maybe FilePath)
programPath context@Context {..} = do
    maybeLatest <- latestBuildStage package
    return $ do
        install <- (\l -> l == stage || package == ghc) <$> maybeLatest
Zhen Zhang's avatar
Zhen Zhang committed
115
        let path = if install then inplaceInstallPath package else buildPath context
Andrey Mokhov's avatar
Andrey Mokhov committed
116
        return $ path -/- programName context <.> exe
Zhen Zhang's avatar
Zhen Zhang committed
117 118 119

pkgConfInstallPath :: FilePath
pkgConfInstallPath = buildPath (vanillaContext Stage0 rts) -/- "package.conf.install"
Zhen Zhang's avatar
Zhen Zhang committed
120 121 122 123 124 125 126 127 128 129

-- | Stage1Only flag
-- TODO: Set this by cmdline flags
stage1Only :: Bool
stage1Only = defaultStage1Only

-- | Install's DESTDIR flag
-- TODO: Set this by cmdline flags
destDir :: FilePath
destDir = defaultDestDir