Program.hs 4.83 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 hiding (stage, way)
8
import GHC
9
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Oracles.PackageData
11
import Oracles.Setting
12
import Rules.Wrappers
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Settings
14
import Settings.Path
15
import Target
16
import Utilities
Andrey Mokhov's avatar
Andrey Mokhov committed
17

18
-- TODO: Drop way in build rule generation?
19
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
Andrey Mokhov's avatar
Andrey Mokhov committed
20
buildProgram rs context@Context {..} = when (isProgram package) $ do
Andrey Mokhov's avatar
Andrey Mokhov committed
21
    let installStage = do
Andrey Mokhov's avatar
Andrey Mokhov committed
22
            latest <- latestBuildStage package -- fromJust below is safe
Andrey Mokhov's avatar
Andrey Mokhov committed
23
24
            return $ if package == ghc then stage else fromJust latest

25
26
27
    buildPath context -/- programName context <.> exe %> \bin -> do
        context' <- programContext stage package
        buildBinaryAndWrapper rs context' bin
Andrey Mokhov's avatar
Andrey Mokhov committed
28

29
30
    when (package == ghc) $ want inplaceLibCopyTargets

Andrey Mokhov's avatar
Andrey Mokhov committed
31
    -- Rules for programs built in install directories
Andrey Mokhov's avatar
Andrey Mokhov committed
32
    when (stage == Stage0 || package == ghc) $ do
33
34
        -- Some binaries in inplace/bin are wrapped
        inplaceBinPath -/- programName context <.> exe %> \bin -> do
35
            context' <- programContext stage package
Andrey Mokhov's avatar
Andrey Mokhov committed
36
            binStage <- installStage
37
            buildBinaryAndWrapper rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
38

39
        inplaceLibBinPath -/- programName context <.> exe %> \bin -> do
Zhen Zhang's avatar
Zhen Zhang committed
40
            binStage <- installStage
41
            context' <- programContext stage package
Zhen Zhang's avatar
Zhen Zhang committed
42
43
            if package /= iservBin then
                -- We *normally* build only unwrapped binaries in inplace/lib/bin,
44
                buildBinary rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
45
46
47
            else
                -- build both binary and wrapper in inplace/lib/bin
                -- for ghc-iserv on *nix platform now
48
                buildBinaryAndWrapperLib rs (context' { stage = binStage }) bin
Zhen Zhang's avatar
Zhen Zhang committed
49
50

        inplaceLibBinPath -/- programName context <.> "bin" %> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
51
            binStage <- installStage
52
53
            context' <- programContext stage package
            buildBinary rs (context' { stage = binStage }) bin
Andrey Mokhov's avatar
Andrey Mokhov committed
54

Zhen Zhang's avatar
Zhen Zhang committed
55
56
57
58
59
60
61
62
63
64
65
66
67
68
buildBinaryAndWrapperLib :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinaryAndWrapperLib rs context bin = do
    windows <- windowsHost
    if windows
    then buildBinary rs context bin -- We don't build wrappers on Windows
    else case lookup context inplaceWrappers of
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- programName context <.> "bin"
            need [wrappedBin]
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName wrappedBin))

Andrey Mokhov's avatar
Andrey Mokhov committed
69
70
71
72
73
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
Zhen Zhang's avatar
Zhen Zhang committed
74
    else case lookup context inplaceWrappers of
Andrey Mokhov's avatar
Andrey Mokhov committed
75
76
        Nothing      -> buildBinary rs context bin -- No wrapper found
        Just wrapper -> do
77
78
79
            top <- topDirectory
            let libdir = top -/- inplaceLibPath
            let wrappedBin = inplaceLibBinPath -/- takeFileName bin
Andrey Mokhov's avatar
Andrey Mokhov committed
80
            need [wrappedBin]
81
            buildWrapper context wrapper bin (WrappedBinary libdir (takeFileName bin))
Andrey Mokhov's avatar
Andrey Mokhov committed
82

83
84
85
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
86
    writeFileChanged wrapperPath contents
87
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
88
89
    putSuccess $ "| Successfully created wrapper for " ++
        quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
90
91

-- TODO: Get rid of the Paths_hsc2hs.o hack.
92
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
93
94
buildBinary rs context@Context {..} bin = do
    binDeps <- if stage == Stage0 && package == ghcCabal
95
        then hsSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
96
        else do
97
            needLibrary =<< contextDependencies context
98
            when (stage > Stage0) $ do
99
                ways <- interpretInContext context (getLibraryWays <> getRtsWays)
100
                needLibrary [ rtsContext { way = w } | w <- ways ]
Andrey Mokhov's avatar
Andrey Mokhov committed
101
            let path = buildPath context
102
103
104
105
106
            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
107
    need binDeps
108
    buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin]
109
    synopsis <- interpretInContext context $ getPkgData Synopsis
Moritz Angermann's avatar
Moritz Angermann committed
110
    putSuccess $ renderProgram
Andrey Mokhov's avatar
Andrey Mokhov committed
111
        (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
Moritz Angermann's avatar
Moritz Angermann committed
112
113
        bin
        (dropWhileEnd isPunctuation synopsis)