ddda4632d405a6fd3d8d785b24eff16344b176d1
[ghc.git] / src / Rules / Program.hs
1 module Rules.Program (buildProgram) where
2
3 import Data.Char
4
5 import Base
6 import Context
7 import Expression
8 import GHC
9 import Oracles.Config.Setting
10 import Oracles.PackageData
11 import Rules.Actions
12 import Rules.Library
13 import Rules.Wrappers.Ghc
14 import Rules.Wrappers.GhcPkg
15 import Settings
16 import Settings.Builders.GhcCabal
17 import Target
18
19 -- TODO: move to buildRootPath, see #113
20 -- Directory for wrapped binaries
21 programInplaceLibPath :: FilePath
22 programInplaceLibPath = "inplace/lib/bin"
23
24 -- Wrapper is parameterised by the path to the wrapped binary
25 type Wrapper = FilePath -> Expr String
26
27 -- List of wrappers we build
28 wrappers :: [(Context, Wrapper)]
29 wrappers = [ (vanillaContext Stage0 ghc , ghcWrapper )
30 , (vanillaContext Stage1 ghc , ghcWrapper )
31 , (vanillaContext Stage0 ghcPkg, ghcPkgWrapper)]
32
33 buildProgram :: [(Resource, Int)] -> Context -> Rules ()
34 buildProgram rs context@Context {..} = do
35 let match file = case programPath context of
36 Nothing -> False
37 Just program -> program == file
38 matchWrapped file = case programPath context of
39 Nothing -> False
40 Just program -> case computeWrappedPath program of
41 Nothing -> False
42 Just wrappedProgram -> wrappedProgram == file
43
44 match ?> \bin -> do
45 windows <- windowsHost
46 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
50 Just (_, wrapper) -> do
51 let Just wrappedBin = computeWrappedPath bin
52 need [wrappedBin]
53 buildWrapper context wrapper bin wrappedBin
54
55 matchWrapped ?> \bin -> buildBinary rs context bin
56
57 -- Replace programInplacePath with programInplaceLibPath in a given path
58 computeWrappedPath :: FilePath -> Maybe FilePath
59 computeWrappedPath =
60 fmap (programInplaceLibPath ++) . stripPrefix programInplacePath
61
62 buildWrapper :: Context -> Wrapper -> FilePath -> FilePath -> Action ()
63 buildWrapper context@Context {..} wrapper wrapperPath binPath = do
64 contents <- interpretInContext context $ wrapper binPath
65 writeFileChanged wrapperPath contents
66 makeExecutable wrapperPath
67 putSuccess $ "| Successfully created wrapper for " ++
68 quote (pkgNameString package) ++ " (" ++ show stage ++ ")."
69
70 -- TODO: Get rid of the Paths_hsc2hs.o hack.
71 -- TODO: Do we need to consider other ways when building programs?
72 buildBinary :: [(Resource, Int)] -> Context -> FilePath -> Action ()
73 buildBinary rs context@(Context stage package _) bin = do
74 let path = buildPath context
75 cSrcs <- cSources context -- TODO: remove code duplication (Library.hs)
76 hSrcs <- hSources context
77 let cObjs = [ path -/- src -<.> osuf vanilla | src <- cSrcs ]
78 hObjs = [ path -/- src <.> osuf vanilla | src <- hSrcs ]
79 ++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
80 ++ [ path -/- "Paths_haddock.o" | package == haddock ]
81 objs = cObjs ++ hObjs
82 ways <- interpretInContext context getLibraryWays
83 depNames <- interpretInContext context $ getPkgDataList TransitiveDepNames
84 let libStage = min stage Stage1 -- libraries are built only in Stage0/1
85 libContext = vanillaContext libStage package
86 pkgs <- interpretInContext libContext getPackages
87 let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
88 libs <- fmap concat . forM deps $ \dep -> do
89 let depContext = vanillaContext libStage dep
90 ghciFlag <- interpretInContext depContext $ getPkgData BuildGhciLib
91 libFiles <- fmap concat . forM ways $ \way -> do
92 libFile <- pkgLibraryFile $ Context libStage dep way
93 lib0File <- pkgLibraryFile0 $ Context libStage dep way
94 dll0 <- needDll0 libStage dep
95 return $ libFile : [ lib0File | dll0 ]
96 ghciLib <- pkgGhciLibraryFile $ vanillaContext libStage dep
97 return $ libFiles ++ [ ghciLib | ghciFlag == "YES" && stage == Stage1 ]
98 let binDeps = if package == ghcCabal && stage == Stage0
99 then [ pkgPath package -/- src <.> "hs" | src <- hSrcs ]
100 else objs
101 need $ binDeps ++ libs
102 buildWithResources rs $ Target context (Ghc Link stage) binDeps [bin]
103 synopsis <- interpretInContext context $ getPkgData Synopsis
104 putSuccess $ renderProgram
105 (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
106 bin
107 (dropWhileEnd isPunctuation synopsis)