Program.hs 4.2 KB
Newer Older
Andrey Mokhov's avatar
Andrey Mokhov committed
1
2
module Rules.Program (buildProgram) where

Ben Gamari's avatar
Ben Gamari committed
3
4
import Data.Char

Ben Gamari's avatar
Ben Gamari committed
5
import Base
6
import Context
7
import Expression
8
import GHC
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import Oracles.Config.Setting
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Oracles.Dependencies
11
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import Oracles.PackageData
13
14
import Oracles.Path (topDirectory)
import Rules.Wrappers (WrappedBinary(..), Wrapper,
15
16
                       ghcWrapper, runGhcWrapper, inplaceGhcPkgWrapper,
                       hpcWrapper, hp2psWrapper, hsc2hsWrapper)
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import Settings
18
19
import Settings.Path (buildPath, inplaceLibBinPath, rtsContext, objectPath,
                      inplaceLibPath, inplaceBinPath)
20
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
21
import UserSettings
22
import Util
Andrey Mokhov's avatar
Andrey Mokhov committed
23

Andrey Mokhov's avatar
Andrey Mokhov committed
24
-- | List of wrappers we build.
25
wrappers :: [(Context, Wrapper)]
26
27
wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper)
           , (vanillaContext Stage1 ghc   , ghcWrapper)
28
           , (vanillaContext Stage1 runGhc, runGhcWrapper)
29
30
31
32
           , (vanillaContext Stage0 ghcPkg, inplaceGhcPkgWrapper)
           , (vanillaContext Stage1 hp2ps , hp2psWrapper)
           , (vanillaContext Stage1 hpc   , hpcWrapper)
           , (vanillaContext Stage1 hsc2hs, hsc2hsWrapper) ]
Andrey Mokhov's avatar
Andrey Mokhov committed
33

34
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
Andrey Mokhov's avatar
Andrey Mokhov committed
35
buildProgram rs context@Context {..} = when (isProgram package) $ do
Andrey Mokhov's avatar
Andrey Mokhov committed
36
    let installStage = do
Andrey Mokhov's avatar
Andrey Mokhov committed
37
            latest <- latestBuildStage package -- fromJust below is safe
Andrey Mokhov's avatar
Andrey Mokhov committed
38
39
            return $ if package == ghc then stage else fromJust latest

Andrey Mokhov's avatar
Andrey Mokhov committed
40
41
42
43
    buildPath context -/- programName context <.> exe %>
        buildBinaryAndWrapper rs context

    -- Rules for programs built in install directories
Andrey Mokhov's avatar
Andrey Mokhov committed
44
    when (stage == Stage0 || package == ghc) $ do
45
46
        -- Some binaries in inplace/bin are wrapped
        inplaceBinPath -/- programName context <.> exe %> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
47
            binStage <- installStage
Andrey Mokhov's avatar
Andrey Mokhov committed
48
            buildBinaryAndWrapper rs (context { stage = binStage }) bin
49
50
        -- We build only unwrapped binaries in inplace/lib/bin
        inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
51
52
            binStage <- installStage
            buildBinary rs (context { stage = binStage }) bin
Andrey Mokhov's avatar
Andrey Mokhov committed
53
54
55
56
57
58
59
60
61

buildBinaryAndWrapper :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinaryAndWrapper rs context bin = do
    windows <- windowsHost
    if windows
    then buildBinary rs context bin -- We don't build wrappers on Windows
    else case lookup context wrappers of
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
62
63
64
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- takeFileName bin
Andrey Mokhov's avatar
Andrey Mokhov committed
65
            need [wrappedBin]
66
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName bin))
Andrey Mokhov's avatar
Andrey Mokhov committed
67

68
69
70
buildWrapper :: Context -> Wrapper -> FilePath -> WrappedBinary -> Action ()
buildWrapper context@Context {..} wrapper wrapperPath wrapped = do
    contents <- interpretInContext context $ wrapper wrapped
Andrey Mokhov's avatar
Andrey Mokhov committed
71
    writeFileChanged wrapperPath contents
72
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
73
74
    putSuccess $ "| Successfully created wrapper for " ++
        quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
75
76

-- TODO: Get rid of the Paths_hsc2hs.o hack.
77
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
78
79
buildBinary rs context@Context {..} bin = do
    binDeps <- if stage == Stage0 && package == ghcCabal
80
        then hsSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
81
        else do
82
            needContext =<< contextDependencies context
83
            when (stage > Stage0) $ do
84
85
                ways <- interpretInContext context (getLibraryWays <> getRtsWays)
                needContext [ rtsContext { way = w } | w <- ways ]
Andrey Mokhov's avatar
Andrey Mokhov committed
86
            let path = buildPath context
87
88
89
90
91
            cObjs  <- map (objectPath context) <$> pkgDataList (CSrcs path)
            hsObjs <- hsObjects context
            return $ cObjs ++ hsObjs
                  ++ [ path -/- "Paths_hsc2hs.o"  | package == hsc2hs  ]
                  ++ [ path -/- "Paths_haddock.o" | package == haddock ]
Andrey Mokhov's avatar
Andrey Mokhov committed
92
    need binDeps
93
    buildWithResources rs $ Target context (Ghc LinkHs stage) binDeps [bin]
94
    synopsis <- interpretInContext context $ getPkgData Synopsis
Moritz Angermann's avatar
Moritz Angermann committed
95
    putSuccess $ renderProgram
Andrey Mokhov's avatar
Andrey Mokhov committed
96
        (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
Moritz Angermann's avatar
Moritz Angermann committed
97
98
        bin
        (dropWhileEnd isPunctuation synopsis)