Program.hs 3.78 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
8
import GHC
Andrey Mokhov's avatar
Andrey Mokhov committed
9
import Oracles.Config.Setting
Andrey Mokhov's avatar
Andrey Mokhov committed
10
import Oracles.Dependencies
Andrey Mokhov's avatar
Andrey Mokhov committed
11
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
Andrey Mokhov's avatar
Andrey Mokhov committed
17
import Settings.Paths
18
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
19
import UserSettings
Andrey Mokhov's avatar
Andrey Mokhov committed
20

Andrey Mokhov's avatar
Andrey Mokhov committed
21
22
-- TODO: Move to buildRootPath, see #113.
-- | Directory for wrapped binaries.
Andrey Mokhov's avatar
Andrey Mokhov committed
23
24
25
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"

Andrey Mokhov's avatar
Andrey Mokhov committed
26
-- | Wrapper is parameterised by the path to the wrapped binary.
Andrey Mokhov's avatar
Andrey Mokhov committed
27
28
type Wrapper = FilePath -> Expr String

Andrey Mokhov's avatar
Andrey Mokhov committed
29
-- | 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
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
36
buildProgram rs context@Context {..} = do
Andrey Mokhov's avatar
Andrey Mokhov committed
37
    let match file = case programPath context of
Andrey Mokhov's avatar
Andrey Mokhov committed
38
            Nothing      -> False
Andrey Mokhov's avatar
Andrey Mokhov committed
39
            Just program -> program == file
Andrey Mokhov's avatar
Andrey Mokhov committed
40
        matchWrapped file = case programPath context 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
        then buildBinary rs context bin -- We don't build wrappers on Windows
50
        else case find ((== context) . fst) wrappers of
51
            Nothing -> buildBinary rs 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 rs 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
buildWrapper :: Context -> Wrapper -> FilePath -> FilePath -> Action ()
65
buildWrapper context@Context {..} wrapper wrapperPath binPath = do
66
    contents <- interpretInContext context $ wrapper binPath
Andrey Mokhov's avatar
Andrey Mokhov committed
67
    writeFileChanged wrapperPath contents
68
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
69
70
    putSuccess $ "| Successfully created wrapper for " ++
        quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
71
72
73

-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
74
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
75
buildBinary rs context@Context {..} bin = do
76
    hsSrcs  <- hsSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
77
    binDeps <- if stage == Stage0 && package == ghcCabal
78
        then return [ pkgPath package -/- src <.> "hs" | src <- hsSrcs ]
Andrey Mokhov's avatar
Andrey Mokhov committed
79
80
81
82
83
84
        else do
            ways <- interpretInContext context getLibraryWays
            deps <- contextDependencies context
            needContext [ dep { way = w } | dep <- deps, w <- ways ]
            cSrcs <- cSources context -- TODO: Drop code duplication (Library.hs).
            let path = buildPath context
85
86
87
88
            return $ [ path -/- "c" -/- src -<.> osuf vanilla | src <- cSrcs       ]
                  ++ [ path -/- src  <.> osuf vanilla         | src <- hsSrcs      ]
                  ++ [ path -/- "Paths_hsc2hs.o"              | package == hsc2hs  ]
                  ++ [ path -/- "Paths_haddock.o"             | package == haddock ]
Andrey Mokhov's avatar
Andrey Mokhov committed
89
    need binDeps
90
    buildWithResources rs $ Target context (Ghc LinkHs stage) binDeps [bin]
91
    synopsis <- interpretInContext context $ getPkgData Synopsis
Moritz Angermann's avatar
Moritz Angermann committed
92
    putSuccess $ renderProgram
Andrey Mokhov's avatar
Andrey Mokhov committed
93
        (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
Moritz Angermann's avatar
Moritz Angermann committed
94
95
        bin
        (dropWhileEnd isPunctuation synopsis)