Program.hs 3.82 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
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Rules.Wrappers.Ghc
Moritz Angermann's avatar
Moritz Angermann committed
14
import Rules.Wrappers.GhcPkg
15
import Rules.Wrappers.RunGhc
Andrey Mokhov's avatar
Andrey Mokhov committed
16
import Settings
17
import Settings.Path
18
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
19
import UserSettings
20
import Util
Andrey Mokhov's avatar
Andrey Mokhov committed
21

22
-- | Wrapper is an expression depending on the 'FilePath' to the wrapped binary.
Andrey Mokhov's avatar
Andrey Mokhov committed
23
24
type Wrapper = FilePath -> Expr String

Andrey Mokhov's avatar
Andrey Mokhov committed
25
-- | List of wrappers we build.
26
27
28
wrappers :: [(Context, Wrapper)]
wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper   )
           , (vanillaContext Stage1 ghc   , ghcWrapper   )
29
           , (vanillaContext Stage1 runGhc, runGhcWrapper)
30
           , (vanillaContext Stage0 ghcPkg, ghcPkgWrapper) ]
Andrey Mokhov's avatar
Andrey Mokhov committed
31

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

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

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

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
            let wrappedBin = programInplaceLibPath -/- takeFileName bin
            need [wrappedBin]
            buildWrapper context wrapper bin wrappedBin
Andrey Mokhov's avatar
Andrey Mokhov committed
63

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

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