Fix warning
[hadrian.git] / src / Rules / Library.hs
1 module Rules.Library (libraryRules) where
2
3 import Hadrian.Haskell.Cabal
4 import Hadrian.Haskell.Cabal.PackageData as PD
5 import Hadrian.Package.Type
6
7 import Base
8 import Context
9 import Expression hiding (way, package)
10 import Flavour
11 import GHC.Packages
12 import Oracles.ModuleFiles
13 import Rules.Gmp
14 import Settings
15 import Target
16 import Utilities
17
18 import Data.Functor
19 import qualified System.Directory as IO
20 import qualified Text.Parsec as Parsec
21
22 -- * Library 'Rules'
23
24 libraryRules :: Rules ()
25 libraryRules = do
26 root <- buildRootRules
27
28 root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib"
29 root -/- "//libHS*-*.so" %> buildDynamicLibUnix root "so"
30 root -/- "//*.a" %> buildStaticLib root
31 priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root
32
33 -- * 'Action's for building libraries
34
35 -- | Build a static library ('LibA') under the given build root, whose
36 -- path is the second argument.
37 buildStaticLib :: FilePath -> FilePath -> Action ()
38 buildStaticLib root archivePath = do
39 l@(BuildPath _ stage _ (LibA pkgname _ way))
40 <- parsePath (parseBuildLibA root)
41 "<.a library (build) path parser>"
42 archivePath
43 let context = libAContext l
44 objs <- libraryObjects context
45 removeFile archivePath
46 build $ target context (Ar Pack stage) objs [archivePath]
47 synopsis <- pkgSynopsis context
48 putSuccess $ renderLibrary
49 (quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
50 archivePath synopsis
51
52 -- | Build a dynamic library ('LibDyn') under the given build root,
53 -- with the given suffix (@.so@ or @.dylib@, @.dll@ in the future),
54 -- where the complete path of the archive to build is given as the
55 -- third argument.
56 buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
57 buildDynamicLibUnix root suffix dynlibpath = do
58 dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
59 let context = libDynContext dynlib
60 deps <- contextDependencies context
61 need =<< mapM pkgLibraryFile deps
62 objs <- libraryObjects context
63 build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
64
65 -- | Build a "ghci library" ('LibGhci') under the given build root,
66 -- with the complete path of the file to build is given as the second
67 -- argument.
68 buildGhciLibO :: FilePath -> FilePath -> Action ()
69 buildGhciLibO root ghcilibPath = do
70 l@(BuildPath _ stage _ (LibGhci _ _ _))
71 <- parsePath (parseBuildLibGhci root)
72 "<.o ghci lib (build) path parser>"
73 ghcilibPath
74 let context = libGhciContext l
75 objs <- allObjects context
76 need objs
77 build $ target context (Ld stage) objs [ghcilibPath]
78
79 -- * Helpers
80
81 -- | Return all Haskell and non-Haskell object files for the
82 -- given 'Context'.
83 allObjects :: Context -> Action [FilePath]
84 allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
85
86 -- | Return all the non-Haskell object files for the given library
87 -- context (object files built from C, C-- and sometimes other things).
88 nonHsObjects :: Context -> Action [FilePath]
89 nonHsObjects context = do
90 cObjs <- cObjects context
91 cmmSrcs <- interpretInContext context (getPackageData PD.cmmSrcs)
92 cmmObjs <- mapM (objectPath context) cmmSrcs
93 eObjs <- extraObjects context
94 return $ cObjs ++ cmmObjs ++ eObjs
95
96 -- | Return all the C object files needed to build the given library
97 -- context.
98 cObjects :: Context -> Action [FilePath]
99 cObjects context = do
100 srcs <- interpretInContext context (getPackageData PD.cSrcs)
101 objs <- mapM (objectPath context) srcs
102 return $ if way context == threaded
103 then objs
104 else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
105
106 -- | Return extra object files needed to build the given library context. The
107 -- resulting list is non empty only when the package from the 'Context' is
108 -- /integer-gmp/.
109 extraObjects :: Context -> Action [FilePath]
110 extraObjects context
111 | package context == integerGmp = do
112 gmpPath <- gmpBuildPath
113 need [gmpPath -/- gmpLibraryH]
114 map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
115 | otherwise = return []
116
117 -- | Return all the object files to be put into the library
118 -- we're building for the given 'Context'.
119 libraryObjects :: Context -> Action [FilePath]
120 libraryObjects context@Context{..} = do
121 hsObjs <- hsObjects context
122 noHsObjs <- nonHsObjects context
123
124 -- This will create split objects if required (we don't track them
125 -- explicitly as this would needlessly bloat the Shake database).
126 need $ noHsObjs ++ hsObjs
127
128 split <- interpretInContext context =<< splitObjects <$> flavour
129 let getSplitObjs = concatForM hsObjs $ \obj -> do
130 let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
131 contents <- liftIO $ IO.getDirectoryContents dir
132 return . map (dir -/-) $ filter (not . all (== '.')) contents
133
134 (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
135
136 -- * Library paths types and parsers
137
138 -- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
139 data LibA = LibA String [Integer] Way
140 deriving (Eq, Show)
141
142 -- | > <so or dylib>
143 data DynLibExt = So | Dylib
144 deriving (Eq, Show)
145
146 -- | > libHS<pkg name>-<pkg version>-ghc<ghc version>[_<way suffix>].<so or dylib>
147 data LibDyn = LibDyn String [Integer] Way DynLibExt
148 deriving (Eq, Show)
149
150 -- | > HS<pkg name>-<pkg version>[_<way suffix>].o
151 data LibGhci = LibGhci String [Integer] Way
152 deriving (Eq, Show)
153
154 -- | A path of the form
155 --
156 -- > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
157 --
158 -- where @something@ describes a library to be build for the given package.
159 --
160 -- @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn'
161 -- and 'LibGhci' successively in this module, depending on the type of library
162 -- we're giving the build rules for.
163 data BuildPath a
164 = BuildPath FilePath -- ^ > <build root>/
165 Stage -- ^ > stage<N>/
166 FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
167 a -- ^ > whatever comes after 'build/'
168 deriving (Eq, Show)
169
170 -- | Get the 'Context' corresponding to the build path for a given static library.
171 libAContext :: BuildPath LibA -> Context
172 libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way))
173 = Context stage pkg way
174 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
175
176 -- | Get the 'Context' corresponding to the build path for a given ghci library.
177 libGhciContext :: BuildPath LibGhci -> Context
178 libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way))
179 = Context stage pkg way
180 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
181
182 -- | Get the 'Context' corresponding to the build path for a given dynamic library.
183 libDynContext :: BuildPath LibDyn -> Context
184 libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _))
185 = Context stage pkg way
186 where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
187
188 -- | Parse a build path for a library to be built under the given build root,
189 -- where the filename will be parsed with the given parser argument.
190 parseBuildPath
191 :: FilePath -- ^ build root
192 -> Parsec.Parsec String () a -- ^ what to parse after @build/@
193 -> Parsec.Parsec String () (BuildPath a)
194 parseBuildPath root afterBuild = do
195 _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
196 stage <- parseStage
197 _ <- Parsec.char '/'
198 pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/")
199 a <- afterBuild
200 return (BuildPath root stage pkgpath a)
201
202 -- | Parse a path to a static library to be built, making sure the path starts
203 -- with the given build root.
204 parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
205 parseBuildLibA root = parseBuildPath root parseLibAFilename
206 Parsec.<?> "build path for a static library"
207
208 -- | Parse a path to a ghci library to be built, making sure the path starts
209 -- with the given build root.
210 parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
211 parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
212 Parsec.<?> "build path for a ghci library"
213
214 -- | Parse a path to a dynamic library to be built, making sure the path starts
215 -- with the given build root.
216 parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
217 parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
218 Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
219
220 -- | Parse the filename of a static library to be built into a 'LibA' value.
221 parseLibAFilename :: Parsec.Parsec String () LibA
222 parseLibAFilename = do
223 _ <- Parsec.string "libHS"
224 (pkgname, pkgver) <- parsePkgId
225 way <- parseWaySuffix vanilla
226 _ <- Parsec.string ".a"
227 return (LibA pkgname pkgver way)
228
229 -- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
230 parseLibGhciFilename :: Parsec.Parsec String () LibGhci
231 parseLibGhciFilename = do
232 _ <- Parsec.string "HS"
233 (pkgname, pkgver) <- parsePkgId
234 way <- parseWaySuffix vanilla
235 _ <- Parsec.string ".o"
236 return (LibGhci pkgname pkgver way)
237
238 -- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
239 parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
240 parseLibDynFilename ext = do
241 _ <- Parsec.string "libHS"
242 (pkgname, pkgver) <- parsePkgId
243 _ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
244 way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
245 _ <- Parsec.string ("." ++ ext)
246 return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
247
248 -- To be kept in sync with Stage.hs's stageString function
249 -- | Parse @"stageX"@ into a 'Stage'.
250 parseStage :: Parsec.Parsec String () Stage
251 parseStage = (Parsec.string "stage" *> Parsec.choice
252 [ Parsec.string (show n) $> toEnum n
253 | n <- map fromEnum [minBound .. maxBound :: Stage]
254 ]) Parsec.<?> "stage string"
255
256 -- To be kept in sync with the show instances in
257 -- Way.Type, until we perhaps use some bidirectional
258 -- parsing/pretty printing approach or library.
259 -- | Parse a way suffix, returning the argument when no suffix is found
260 -- (the argument will be vanilla in most cases, but dynamic when we parse
261 -- the way suffix out of a shared library file name.
262 parseWaySuffix :: Way -> Parsec.Parsec String () Way
263 parseWaySuffix w = Parsec.choice
264 [ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
265 , pure w
266 ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
267
268 where parseWayUnit = Parsec.choice
269 [ Parsec.string "thr" *> pure Threaded
270 , Parsec.char 'd' *>
271 (Parsec.choice
272 [ Parsec.string "ebug" *> pure Debug
273 , Parsec.string "yn" *> pure Dynamic
274 ]
275 )
276 , Parsec.char 'p' *> pure Profiling
277 , Parsec.char 'l' *> pure Logging
278 ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
279
280 -- | Parse a @"pkgname-pkgversion"@ string into
281 -- the package name and the integers that make up the
282 -- package version.
283 parsePkgId :: Parsec.Parsec String () (String, [Integer])
284 parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
285
286 where parsePkgId' currName = do
287 s <- Parsec.many1 Parsec.alphaNum
288 _ <- Parsec.char '-'
289 let newName = if null currName then s else currName ++ "-" ++ s
290 Parsec.choice [ (newName,) <$> parsePkgVersion
291 , parsePkgId' newName
292 ]
293
294 -- | Parse "."-separated integers that describe a package's version.
295 parsePkgVersion :: Parsec.Parsec String () [Integer]
296 parsePkgVersion = fmap reverse (parsePkgVersion' []) Parsec.<?> "package version"
297
298 where parsePkgVersion' xs = do
299 n <- parseNatural
300 Parsec.choice
301 [ Parsec.try (Parsec.lookAhead (Parsec.char '.' *> (Parsec.letter <|> Parsec.char '_')))
302 $> (n:xs)
303 , Parsec.char '.' *> parsePkgVersion' (n:xs)
304 , pure $ (n:xs)
305 ]
306
307 -- | Parse a natural number.
308 parseNatural :: Parsec.Parsec String () Integer
309 parseNatural = (read <$> Parsec.many1 Parsec.digit)
310 Parsec.<?> "natural number"
311
312 -- | Runs the given parser against the given path,
313 -- erroring out when the parser fails (because it shouldn't
314 -- if the code from this module is correct).
315 parsePath
316 :: Parsec.Parsec String () a -- ^ parser to run
317 -> String -- ^ string describing the input source
318 -> FilePath -- ^ path to parse
319 -> Action a
320 parsePath p inp path = case Parsec.parse p inp path of
321 Left err -> fail $ "Rules.Library.parsePath: path="
322 ++ path ++ ", error:\n" ++ show err
323 Right a -> pure a