Drop redundant brackets.
[hadrian.git] / src / Rules / Library.hs
1 module Rules.Library (
2 buildPackageLibrary, buildPackageGhciLibrary, cSources, hSources
3 ) where
4
5 import Data.Char
6 import qualified System.Directory as IO
7
8 import Base hiding (split, splitPath)
9 import Context
10 import Expression
11 import GHC
12 import Oracles.PackageData
13 import Rules.Actions
14 import Rules.Gmp
15 import Settings
16 import Target
17
18 buildPackageLibrary :: Context -> Rules ()
19 buildPackageLibrary context @ Context {..} = do
20 let buildPath = contextPath context -/- "build"
21 libPrefix = buildPath -/- "libHS" ++ pkgNameString package
22
23 -- TODO: handle dynamic libraries
24 matchVersionedFilePath libPrefix (waySuffix way <.> "a") ?> \a -> do
25 removeFileIfExists a
26 cSrcs <- cSources context
27 hSrcs <- hSources context
28
29 -- TODO: simplify handling of AutoApply.cmm, eliminate differences below
30 let cObjs = [ buildPath -/- src -<.> osuf way | src <- cSrcs
31 , not ("//AutoApply.cmm" ?== src) ]
32 ++ [ src -<.> osuf way | src <- cSrcs, "//AutoApply.cmm" ?== src ]
33 hObjs = [ buildPath -/- src <.> osuf way | src <- hSrcs ]
34
35 -- This will create split objects if required (we don't track them
36 -- explicitly as this would needlessly bloat the Shake database).
37 need $ cObjs ++ hObjs
38
39 split <- interpretInContext context splitObjects
40 splitObjs <- if not split then return hObjs else -- TODO: make clearer!
41 fmap concat $ forM hSrcs $ \src -> do
42 let splitPath = buildPath -/- src ++ "_" ++ osuf way ++ "_split"
43 contents <- liftIO $ IO.getDirectoryContents splitPath
44 return . map (splitPath -/-)
45 . filter (not . all (== '.')) $ contents
46
47 eObjs <- extraObjects context
48 let objs = cObjs ++ splitObjs ++ eObjs
49
50 asuf <- libsuf way
51 let isLib0 = ("//*-0" ++ asuf) ?== a
52 if isLib0
53 then build $ Target context Ar [] [a] -- TODO: scan for dlls
54 else build $ Target context Ar objs [a]
55
56 synopsis <- interpretInContext context $ getPkgData Synopsis
57 unless isLib0 . putSuccess $ renderLibrary
58 ("'" ++ pkgNameString package ++ "' (" ++ show stage ++ ", way "++ show way ++ ").")
59 a
60 (dropWhileEnd isPunctuation synopsis)
61
62 buildPackageGhciLibrary :: Context -> Rules ()
63 buildPackageGhciLibrary context @ Context {..} = priority 2 $ do
64 let buildPath = contextPath context -/- "build"
65 libPrefix = buildPath -/- "HS" ++ pkgNameString package
66
67 -- TODO: simplify handling of AutoApply.cmm
68 matchVersionedFilePath libPrefix (waySuffix way <.> "o") ?> \obj -> do
69 cSrcs <- cSources context
70 hSrcs <- hSources context
71 let cObjs = [ buildPath -/- src -<.> "o" | src <- cSrcs
72 , not ("//AutoApply.cmm" ?== src) ]
73 ++ [ src -<.> "o" | src <- cSrcs, "//AutoApply.cmm" ?== src ]
74 hObjs = [ buildPath -/- src <.> "o" | src <- hSrcs ]
75 need $ cObjs ++ hObjs
76 build $ Target context Ld (cObjs ++ hObjs) [obj]
77
78 cSources :: Context -> Action [FilePath]
79 cSources context = interpretInContext context $ getPkgDataList CSrcs
80
81 hSources :: Context -> Action [FilePath]
82 hSources context = do
83 modules <- interpretInContext context $ getPkgDataList Modules
84 -- GHC.Prim is special: we do not build it
85 return . map (replaceEq '.' '/') . filter (/= "GHC.Prim") $ modules
86
87 extraObjects :: Context -> Action [FilePath]
88 extraObjects (Context _ package _)
89 | package == integerGmp = do
90 orderOnly [gmpLibraryH] -- TODO: move this dependency elsewhere, #113?
91 -- FIXME: simplify after Shake's getDirectoryFiles bug is fixed, #168
92 exists <- doesDirectoryExist gmpObjects
93 if exists
94 then map unifyPath <$> getDirectoryFiles "" [gmpObjects -/- "*.o"]
95 else return []
96 | otherwise = return []