Refactor dependency oracles
[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.Dependencies
11 import Oracles.PackageData
12 import Rules.Actions
13 import Rules.Library
14 import Rules.Wrappers.Ghc
15 import Rules.Wrappers.GhcPkg
16 import Settings
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 {..} bin = do
74 hSrcs <- hSources context
75 binDeps <- if stage == Stage0 && package == ghcCabal
76 then return [ pkgPath package -/- src <.> "hs" | src <- hSrcs ]
77 else do
78 ways <- interpretInContext context getLibraryWays
79 deps <- contextDependencies context
80 needContext [ dep { way = w } | dep <- deps, w <- ways ]
81 cSrcs <- cSources context -- TODO: Drop code duplication (Library.hs).
82 let path = buildPath context
83 return $ [ path -/- src -<.> osuf vanilla | src <- cSrcs ]
84 ++ [ path -/- src <.> osuf vanilla | src <- hSrcs ]
85 ++ [ path -/- "Paths_hsc2hs.o" | package == hsc2hs ]
86 ++ [ path -/- "Paths_haddock.o" | package == haddock ]
87 need binDeps
88 buildWithResources rs $ Target context (Ghc Link stage) binDeps [bin]
89 synopsis <- interpretInContext context $ getPkgData Synopsis
90 putSuccess $ renderProgram
91 (quote (pkgNameString package) ++ " (" ++ show stage ++ ").")
92 bin
93 (dropWhileEnd isPunctuation synopsis)