Program.hs 4.62 KB
Newer Older
1
{-# LANGUAGE RecordWildCards #-}
Andrey Mokhov's avatar
Andrey Mokhov committed
2
3
module Rules.Program (buildProgram) where

Ben Gamari's avatar
Ben Gamari committed
4
5
import Data.Char

Ben Gamari's avatar
Ben Gamari committed
6
import Base
7
import Context
8
import Expression
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import GHC hiding (ghci)
Andrey Mokhov's avatar
Andrey Mokhov committed
10
11
import Oracles.Config.Setting
import Oracles.PackageData
Andrey Mokhov's avatar
Andrey Mokhov committed
12
13
import Rules.Actions
import Rules.Library
Andrey Mokhov's avatar
Andrey Mokhov committed
14
import Rules.Wrappers.Ghc
Moritz Angermann's avatar
Moritz Angermann committed
15
import Rules.Wrappers.GhcPkg
Andrey Mokhov's avatar
Andrey Mokhov committed
16
import Settings
17
import Settings.Builders.GhcCabal
18
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
19

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

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

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

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

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

63
64
65
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
66
    writeFileChanged wrapperPath contents
67
    makeExecutable wrapperPath
68
    putSuccess $ "| Successfully created wrapper for '" ++ pkgNameString package
Andrey Mokhov's avatar
Andrey Mokhov committed
69
70
71
72
               ++ "' (" ++ show stage ++ ")."

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