Program.hs 4.63 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
Moritz Angermann's avatar
Moritz Angermann committed
13
import Rules.Wrappers.GhcPkg
Andrey Mokhov's avatar
Andrey Mokhov committed
14
import Settings
15
import Settings.Builders.GhcCabal
Andrey Mokhov's avatar
Andrey Mokhov committed
16

Andrey Mokhov's avatar
Andrey Mokhov committed
17
18
19
20
21
22
23
24
25
-- 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)]
Moritz Angermann's avatar
Moritz Angermann committed
26
wrappers = [ (PartialTarget Stage0 ghc, ghcWrapper)
Moritz Angermann's avatar
Moritz Angermann committed
27
           , (PartialTarget Stage1 ghc, ghcWrapper)
Moritz Angermann's avatar
Moritz Angermann committed
28
           , (PartialTarget Stage0 ghcPkg, ghcPkgWrapper)]
Andrey Mokhov's avatar
Andrey Mokhov committed
29

Andrey Mokhov's avatar
Andrey Mokhov committed
30
31
buildProgram :: Resources -> PartialTarget -> Rules ()
buildProgram _ target @ (PartialTarget stage pkg) = do
Andrey Mokhov's avatar
Andrey Mokhov committed
32
    let match file = case programPath stage pkg of
Andrey Mokhov's avatar
Andrey Mokhov committed
33
            Nothing      -> False
Andrey Mokhov's avatar
Andrey Mokhov committed
34
            Just program -> program == file
Andrey Mokhov's avatar
Andrey Mokhov committed
35
36
37
38
39
        matchWrapped file = case programPath stage pkg of
            Nothing      -> False
            Just program -> case computeWrappedPath program of
                Nothing             -> False
                Just wrappedProgram -> wrappedProgram == file
Andrey Mokhov's avatar
Andrey Mokhov committed
40

Andrey Mokhov's avatar
Andrey Mokhov committed
41
    match ?> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
42
43
44
45
46
47
        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
Andrey Mokhov's avatar
Andrey Mokhov committed
48
49
                let Just wrappedBin = computeWrappedPath bin
                need [wrappedBin]
Andrey Mokhov's avatar
Andrey Mokhov committed
50
51
                buildWrapper target wrapper bin wrappedBin

Andrey Mokhov's avatar
Andrey Mokhov committed
52
53
    matchWrapped ?> \bin -> buildBinary target bin

Andrey Mokhov's avatar
Andrey Mokhov committed
54
-- Replace programInplacePath with programInplaceLibPath in a given path
Andrey Mokhov's avatar
Andrey Mokhov committed
55
56
57
computeWrappedPath :: FilePath -> Maybe FilePath
computeWrappedPath =
    fmap (programInplaceLibPath ++) . stripPrefix programInplacePath
Andrey Mokhov's avatar
Andrey Mokhov committed
58
59
60
61
62

buildWrapper :: PartialTarget -> Wrapper -> FilePath -> FilePath -> Action ()
buildWrapper target @ (PartialTarget stage pkg) wrapper wrapperPath binPath = do
    contents <- interpretPartial target $ wrapper binPath
    writeFileChanged wrapperPath contents
63
    unit $ cmd "chmod +x " [wrapperPath]
Andrey Mokhov's avatar
Andrey Mokhov committed
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
99
100
101
102
103
104
105
106
    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
Andrey Mokhov's avatar
Andrey Mokhov committed
107
        , "Program synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]