Program.hs 3.17 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
11
import Oracles.ModuleFiles
Andrey Mokhov's avatar
Andrey Mokhov committed
12
import Oracles.PackageData
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.Path
17
import Target
Andrey Mokhov's avatar
Andrey Mokhov committed
18
import UserSettings
19
import Util
Andrey Mokhov's avatar
Andrey Mokhov committed
20

21
-- | Wrapper is an expression depending on the 'FilePath' to the wrapped binary.
Andrey Mokhov's avatar
Andrey Mokhov committed
22
23
type Wrapper = FilePath -> Expr String

Andrey Mokhov's avatar
Andrey Mokhov committed
24
-- | List of wrappers we build.
25
26
27
wrappers :: [(Context, Wrapper)]
wrappers = [ (vanillaContext Stage0 ghc   , ghcWrapper   )
           , (vanillaContext Stage1 ghc   , ghcWrapper   )
28
           , (vanillaContext Stage0 ghcPkg, ghcPkgWrapper) ]
Andrey Mokhov's avatar
Andrey Mokhov committed
29

30
buildProgram :: [(Resource, Int)] -> Context -> Rules ()
31
buildProgram rs context@Context {..} = do
32
33
    let match file        = any (== file) (programPath context)
        matchWrapped file = any (== file) (programPath context >>= wrappedPath)
Andrey Mokhov's avatar
Andrey Mokhov committed
34
    match ?> \bin -> do
Andrey Mokhov's avatar
Andrey Mokhov committed
35
36
        windows <- windowsHost
        if windows
37
        then buildBinary rs context bin -- We don't build wrappers on Windows
38
39
40
41
        else case lookup context wrappers of
            Nothing      -> buildBinary rs context bin -- No wrapper found
            Just wrapper -> do
                let Just wrappedBin = wrappedPath bin
Andrey Mokhov's avatar
Andrey Mokhov committed
42
                need [wrappedBin]
43
                buildWrapper context wrapper bin wrappedBin
Andrey Mokhov's avatar
Andrey Mokhov committed
44

45
    matchWrapped ?> buildBinary rs context
Andrey Mokhov's avatar
Andrey Mokhov committed
46

Andrey Mokhov's avatar
Andrey Mokhov committed
47
-- | Replace 'programInplacePath' with 'programInplaceLibPath' in a given path.
48
49
wrappedPath :: FilePath -> Maybe FilePath
wrappedPath = fmap (programInplaceLibPath ++) . stripPrefix programInplacePath
Andrey Mokhov's avatar
Andrey Mokhov committed
50

51
buildWrapper :: Context -> Wrapper -> FilePath -> FilePath -> Action ()
52
buildWrapper context@Context {..} wrapper wrapperPath binPath = do
53
    contents <- interpretInContext context $ wrapper binPath
Andrey Mokhov's avatar
Andrey Mokhov committed
54
    writeFileChanged wrapperPath contents
55
    makeExecutable wrapperPath
Andrey Mokhov's avatar
Andrey Mokhov committed
56
57
    putSuccess $ "| Successfully created wrapper for " ++
        quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
Andrey Mokhov's avatar
Andrey Mokhov committed
58
59
60

-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
61
buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
Andrey Mokhov's avatar
Andrey Mokhov committed
62
63
buildBinary rs context@Context {..} bin = do
    binDeps <- if stage == Stage0 && package == ghcCabal
64
        then hsSources context
Andrey Mokhov's avatar
Andrey Mokhov committed
65
66
67
68
69
        else do
            ways <- interpretInContext context getLibraryWays
            deps <- contextDependencies context
            needContext [ dep { way = w } | dep <- deps, w <- ways ]
            let path = buildPath context
70
71
72
73
74
            cObjs  <- map (objectPath context) <$> pkgDataList (CSrcs path)
            hsObjs <- hsObjects context
            return $ cObjs ++ hsObjs
                  ++ [ path -/- "Paths_hsc2hs.o"  | package == hsc2hs  ]
                  ++ [ path -/- "Paths_haddock.o" | package == haddock ]
Andrey Mokhov's avatar
Andrey Mokhov committed
75
    need binDeps
76
    buildWithResources rs $ Target context (Ghc LinkHs stage) binDeps [bin]
77
    synopsis <- interpretInContext context $ getPkgData Synopsis
Moritz Angermann's avatar
Moritz Angermann committed
78
    putSuccess $ renderProgram
Andrey Mokhov's avatar
Andrey Mokhov committed
79
        (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
Moritz Angermann's avatar
Moritz Angermann committed
80
81
        bin
        (dropWhileEnd isPunctuation synopsis)