Program.hs 4.61 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
Andrey Mokhov's avatar
Andrey Mokhov committed
8
import GHC hiding (ghci)
Andrey Mokhov's avatar
Andrey Mokhov committed
9
10
import Oracles.Config.Setting
import Oracles.PackageData
Andrey Mokhov's avatar
Andrey Mokhov committed
11
12
import Rules.Actions
import Rules.Library
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
17
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
18

19
-- TODO: move to buildRootPath, see #113
Andrey Mokhov's avatar
Andrey Mokhov committed
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
28
29
30
31
wrappers :: [(Context, Wrapper)]
wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper   )
           , (vanillaContext Stage1 ghc   , ghcWrapper   )
           , (vanillaContext Stage0 ghcPkg, ghcPkgWrapper)]
Andrey Mokhov's avatar
Andrey Mokhov committed
32

33
34
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
buildProgram rs context @ (Context {..}) = do
Andrey Mokhov's avatar
Andrey Mokhov committed
35
    let match file = case programPath context of
Andrey Mokhov's avatar
Andrey Mokhov committed
36
            Nothing      -> False
Andrey Mokhov's avatar
Andrey Mokhov committed
37
            Just program -> program == file
Andrey Mokhov's avatar
Andrey Mokhov committed
38
        matchWrapped file = case programPath context of
Andrey Mokhov's avatar
Andrey Mokhov committed
39
40
41
42
            Nothing      -> False
            Just program -> case computeWrappedPath program of
                Nothing             -> False
                Just wrappedProgram -> wrappedProgram == file
Andrey Mokhov's avatar
Andrey Mokhov committed
43

Andrey Mokhov's avatar
Andrey Mokhov committed
44
    match ?> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
45
46
        windows <- windowsHost
        if windows
47
        then buildBinary rs context bin -- We don't build wrappers on Windows
48
        else case find ((== context) . fst) wrappers of
49
            Nothing -> buildBinary rs context bin -- No wrapper found
Andrey Mokhov's avatar
Andrey Mokhov committed
50
            Just (_, wrapper) -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
51
52
                let Just wrappedBin = computeWrappedPath bin
                need [wrappedBin]
53
                buildWrapper context wrapper bin wrappedBin
Andrey Mokhov's avatar
Andrey Mokhov committed
54

55
    matchWrapped ?> \bin -> buildBinary rs context bin
Andrey Mokhov's avatar
Andrey Mokhov committed
56

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

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

-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
72
73
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
buildBinary rs context @ (Context stage package _) bin = do
Andrey Mokhov's avatar
Andrey Mokhov committed
74
    let buildPath = contextPath context -/- "build"
75
76
    cSrcs <- cSources context -- TODO: remove code duplication (Library.hs)
    hSrcs <- hSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
77
78
    let cObjs = [ buildPath -/- src -<.> osuf vanilla | src <- cSrcs   ]
        hObjs = [ buildPath -/- src  <.> osuf vanilla | src <- hSrcs   ]
79
80
             ++ [ buildPath -/- "Paths_hsc2hs.o"      | package == hsc2hs  ]
             ++ [ buildPath -/- "Paths_haddock.o"     | package == haddock ]
Andrey Mokhov's avatar
Andrey Mokhov committed
81
        objs  = cObjs ++ hObjs
82
83
84
85
    ways     <- interpretInContext context getLibraryWays
    depNames <- interpretInContext context $ getPkgDataList TransitiveDepNames
    let libStage   = min stage Stage1 -- libraries are built only in Stage0/1
        libContext = vanillaContext libStage package
86
    pkgs <- interpretInContext libContext getPackages
Andrey Mokhov's avatar
Andrey Mokhov committed
87
88
    let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
    libs <- fmap concat . forM deps $ \dep -> do
89
90
        let depContext = vanillaContext libStage dep
        ghciFlag <- interpretInContext depContext $ getPkgData BuildGhciLib
Andrey Mokhov's avatar
Andrey Mokhov committed
91
        libFiles <- fmap concat . forM ways $ \way -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
92
93
            libFile  <- pkgLibraryFile  $ Context libStage dep way
            lib0File <- pkgLibraryFile0 $ Context libStage dep way
Andrey Mokhov's avatar
Andrey Mokhov committed
94
            dll0     <- needDll0 libStage dep
Moritz Angermann's avatar
Moritz Angermann committed
95
            return $ libFile : [ lib0File | dll0 ]
Andrey Mokhov's avatar
Andrey Mokhov committed
96
        ghciLib <- pkgGhciLibraryFile $ vanillaContext libStage dep
97
        return $ libFiles ++ [ ghciLib | ghciFlag == "YES" && stage == Stage1 ]
98
99
    let binDeps = if package == ghcCabal && stage == Stage0
                  then [ pkgPath package -/- src <.> "hs" | src <- hSrcs ]
Andrey Mokhov's avatar
Andrey Mokhov committed
100
101
                  else objs
    need $ binDeps ++ libs
102
    buildWithResources rs $ Target context (Ghc stage) binDeps [bin]
103
    synopsis <- interpretInContext context $ getPkgData Synopsis
Moritz Angermann's avatar
Moritz Angermann committed
104
    putSuccess $ renderProgram
105
        ("'" ++ pkgNameString package ++ "' (" ++ show stage ++ ").")
Moritz Angermann's avatar
Moritz Angermann committed
106
107
        bin
        (dropWhileEnd isPunctuation synopsis)