Program.hs 4.46 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
import Oracles.Config.Setting
import Oracles.PackageData
Andrey Mokhov's avatar
Andrey Mokhov committed
10
11
12
import Rules.Actions
import Rules.Library
import Rules.Resources
Andrey Mokhov's avatar
Andrey Mokhov committed
13
import Rules.Wrappers.Ghc
Moritz Angermann's avatar
Moritz Angermann committed
14
import Rules.Wrappers.GhcPkg
Andrey Mokhov's avatar
Andrey Mokhov committed
15
import Settings
16
import Settings.Builders.GhcCabal
Andrey Mokhov's avatar
Andrey Mokhov committed
17

18
-- TODO: move to buildRootPath, see #113
Andrey Mokhov's avatar
Andrey Mokhov committed
19
20
21
22
23
24
25
26
27
-- 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
28
wrappers = [ (PartialTarget Stage0 ghc, ghcWrapper)
Moritz Angermann's avatar
Moritz Angermann committed
29
           , (PartialTarget Stage1 ghc, ghcWrapper)
Moritz Angermann's avatar
Moritz Angermann committed
30
           , (PartialTarget Stage0 ghcPkg, ghcPkgWrapper)]
Andrey Mokhov's avatar
Andrey Mokhov committed
31

Andrey Mokhov's avatar
Andrey Mokhov committed
32
33
buildProgram :: Resources -> PartialTarget -> Rules ()
buildProgram _ target @ (PartialTarget stage pkg) = do
Andrey Mokhov's avatar
Andrey Mokhov committed
34
    let match file = case programPath stage pkg of
Andrey Mokhov's avatar
Andrey Mokhov committed
35
            Nothing      -> False
Andrey Mokhov's avatar
Andrey Mokhov committed
36
            Just program -> program == file
Andrey Mokhov's avatar
Andrey Mokhov committed
37
38
39
40
41
        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
42

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

Andrey Mokhov's avatar
Andrey Mokhov committed
54
55
    matchWrapped ?> \bin -> buildBinary target bin

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

buildWrapper :: PartialTarget -> Wrapper -> FilePath -> FilePath -> Action ()
buildWrapper target @ (PartialTarget stage pkg) wrapper wrapperPath binPath = do
    contents <- interpretPartial target $ wrapper binPath
    writeFileChanged wrapperPath contents
65
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
66
67
68
69
70
71
72
    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
73
    let buildPath = targetPath stage pkg -/- "build"
Andrey Mokhov's avatar
Andrey Mokhov committed
74
75
76
77
78
79
80
    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
81
    ways     <- interpretPartial target getLibraryWays
Andrey Mokhov's avatar
Andrey Mokhov committed
82
83
84
85
86
87
88
89
90
    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
        libFiles <- fmap concat . forM ways $ \way -> do
91
92
            libFile  <- pkgLibraryFile  libStage dep way
            lib0File <- pkgLibraryFile0 libStage dep way
Andrey Mokhov's avatar
Andrey Mokhov committed
93
            dll0     <- needDll0 libStage dep
Moritz Angermann's avatar
Moritz Angermann committed
94
            return $ libFile : [ lib0File | dll0 ]
95
96
        ghciLib <- pkgGhciLibraryFile libStage dep
        return $ libFiles ++ [ ghciLib | ghci ]
Andrey Mokhov's avatar
Andrey Mokhov committed
97
98
99
100
101
102
    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
Moritz Angermann's avatar
Moritz Angermann committed
103
    putSuccess $ renderProgram
Moritz Angermann's avatar
Moritz Angermann committed
104
105
106
        ("'" ++ pkgNameString pkg ++ "' (" ++ show stage ++ ").")
        bin
        (dropWhileEnd isPunctuation synopsis)