Program.hs 4.55 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
14
import Rules.Actions
import Rules.Library
import Rules.Resources
Andrey Mokhov's avatar
Andrey Mokhov committed
15
import Rules.Wrappers.Ghc
Moritz Angermann's avatar
Moritz Angermann committed
16
import Rules.Wrappers.GhcPkg
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import Settings
18
import Settings.Builders.GhcCabal
19
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
20

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

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

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

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

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

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

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