Program.hs 4.26 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 Expression
Andrey Mokhov's avatar
Andrey Mokhov committed
7
import GHC hiding (ghci)
Andrey Mokhov's avatar
Andrey Mokhov committed
8
9
10
11
import Oracles
import Rules.Actions
import Rules.Library
import Rules.Resources
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import Rules.Wrappers.Ghc
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Settings
14
import Settings.Builders.GhcCabal
Andrey Mokhov's avatar
Andrey Mokhov committed
15

Andrey Mokhov's avatar
Andrey Mokhov committed
16
17
18
19
20
21
22
23
24
25
26
-- Directory for wrapped binaries
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"

-- Wrapper is parameterised by the path to the wrapped binary
type Wrapper = FilePath -> Expr String

-- List of wrappers we build
wrappers :: [(PartialTarget, Wrapper)]
wrappers = [(PartialTarget Stage0 ghc, ghcWrapper)]

Andrey Mokhov's avatar
Andrey Mokhov committed
27
28
buildProgram :: Resources -> PartialTarget -> Rules ()
buildProgram _ target @ (PartialTarget stage pkg) = do
Andrey Mokhov's avatar
Andrey Mokhov committed
29
    let match file = case programPath stage pkg of
Andrey Mokhov's avatar
Andrey Mokhov committed
30
            Nothing      -> False
Andrey Mokhov's avatar
Andrey Mokhov committed
31
            Just program -> program == file
Andrey Mokhov's avatar
Andrey Mokhov committed
32

Andrey Mokhov's avatar
Andrey Mokhov committed
33
    match ?> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
        windows <- windowsHost
        if windows
        then buildBinary target bin -- We don't build wrappers on Windows
        else case find ((== target) . fst) wrappers of
            Nothing -> buildBinary target bin -- No wrapper found
            Just (_, wrapper) -> do
                wrappedBin <- moveToLib bin
                buildBinary target wrappedBin
                buildWrapper target wrapper bin wrappedBin

-- Replace programInplacePath with programInplaceLibPath in a given path
moveToLib :: FilePath -> Action FilePath
moveToLib path = case stripPrefix programInplacePath path of
    Just suffix -> return $ programInplaceLibPath ++ suffix
    Nothing     -> putError $ "moveToLib: cannot move " ++ path

buildWrapper :: PartialTarget -> Wrapper -> FilePath -> FilePath -> Action ()
buildWrapper target @ (PartialTarget stage pkg) wrapper wrapperPath binPath = do
    contents <- interpretPartial target $ wrapper binPath
    writeFileChanged wrapperPath contents
    () <- cmd "chmod +x " [wrapperPath]
    putSuccess $ "| Successfully created wrapper for '" ++ pkgNameString pkg
               ++ "' (" ++ show stage ++ ")."

-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
buildBinary :: PartialTarget -> FilePath -> Action ()
buildBinary target @ (PartialTarget stage pkg) bin = do
    let path       = targetPath stage pkg
        buildPath  = path -/- "build"
    cSrcs <- cSources target -- TODO: remove code duplication (Library.hs)
    hSrcs <- hSources target
    let cObjs = [ buildPath -/- src -<.> osuf vanilla | src <- cSrcs   ]
        hObjs = [ buildPath -/- src  <.> osuf vanilla | src <- hSrcs   ]
             ++ [ buildPath -/- "Paths_hsc2hs.o"      | pkg == hsc2hs  ]
             ++ [ buildPath -/- "Paths_haddock.o"     | pkg == haddock ]
        objs  = cObjs ++ hObjs
    ways     <- interpretPartial target getWays
    depNames <- interpretPartial target $ getPkgDataList TransitiveDepNames
    let libStage  = min stage Stage1 -- libraries are built only in Stage0/1
        libTarget = PartialTarget libStage pkg
    pkgs     <- interpretPartial libTarget getPackages
    ghciFlag <- interpretPartial libTarget $ getPkgData BuildGhciLib
    let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
        ghci = ghciFlag == "YES" && stage == Stage1
    libs <- fmap concat . forM deps $ \dep -> do
        let depTarget = PartialTarget libStage dep
        compId <- interpretPartial depTarget $ getPkgData ComponentId
        libFiles <- fmap concat . forM ways $ \way -> do
            libFile  <- pkgLibraryFile libStage dep compId           way
            lib0File <- pkgLibraryFile libStage dep (compId ++ "-0") way
            dll0     <- needDll0 libStage dep
            return $ [ libFile ] ++ [ lib0File | dll0 ]
        return $ libFiles ++ [ pkgGhciLibraryFile libStage dep compId | ghci ]
    let binDeps = if pkg == ghcCabal && stage == Stage0
                  then [ pkgPath pkg -/- src <.> "hs" | src <- hSrcs ]
                  else objs
    need $ binDeps ++ libs
    build $ fullTargetWithWay target (Ghc stage) vanilla binDeps [bin]
    synopsis <- interpretPartial target $ getPkgData Synopsis
    putSuccess $ renderBox
        [ "Successfully built program '"
          ++ pkgNameString pkg ++ "' (" ++ show stage ++ ")."
        , "Executable: " ++ bin
        , "Package synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]