Commit a1eab187 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Add support for wrappers.

parent 0ceae643
......@@ -9,52 +9,90 @@ import Oracles
import Rules.Actions
import Rules.Library
import Rules.Resources
import Rules.Wrappers.Ghc
import Settings
import Settings.Builders.GhcCabal
-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
-- Directory for wrapped binaries
programInplaceLibPath :: FilePath
programInplaceLibPath = "inplace/lib/bin"
-- Wrapper is parameterised by the path to the wrapped binary
type Wrapper = FilePath -> Expr String
-- List of wrappers we build
wrappers :: [(PartialTarget, Wrapper)]
wrappers = [(PartialTarget Stage0 ghc, ghcWrapper)]
buildProgram :: Resources -> PartialTarget -> Rules ()
buildProgram _ target @ (PartialTarget stage pkg) = do
let path = targetPath stage pkg
buildPath = path -/- "build"
match file = case programPath stage pkg of
let match file = case programPath stage pkg of
Nothing -> False
Just prgPath -> ("//" ++ prgPath) ?== file
Just program -> program == file
match ?> \bin -> do
cSrcs <- cSources target -- TODO: remove code duplication (Library.hs)
hSrcs <- hSources target
let cObjs = [ buildPath -/- src -<.> osuf vanilla | src <- cSrcs ]
hObjs = [ buildPath -/- src <.> osuf vanilla | src <- hSrcs ]
++ [ buildPath -/- "Paths_hsc2hs.o" | pkg == hsc2hs ]
++ [ buildPath -/- "Paths_haddock.o" | pkg == haddock ]
objs = cObjs ++ hObjs
ways <- interpretPartial target getWays
depNames <- interpretPartial target $ getPkgDataList TransitiveDepNames
let libStage = min stage Stage1 -- libraries are built only in Stage0/1
libTarget = PartialTarget libStage pkg
pkgs <- interpretPartial libTarget getPackages
ghciFlag <- interpretPartial libTarget $ getPkgData BuildGhciLib
let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
ghci = ghciFlag == "YES" && stage == Stage1
libs <- fmap concat . forM deps $ \dep -> do
let depTarget = PartialTarget libStage dep
compId <- interpretPartial depTarget $ getPkgData ComponentId
libFiles <- fmap concat . forM ways $ \way -> do
libFile <- pkgLibraryFile libStage dep compId way
lib0File <- pkgLibraryFile libStage dep (compId ++ "-0") way
dll0 <- needDll0 libStage dep
return $ [ libFile ] ++ [ lib0File | dll0 ]
return $ libFiles ++ [ pkgGhciLibraryFile libStage dep compId | ghci ]
let binDeps = if pkg == ghcCabal && stage == Stage0
then [ pkgPath pkg -/- src <.> "hs" | src <- hSrcs ]
else objs
need $ binDeps ++ libs
build $ fullTargetWithWay target (Ghc stage) vanilla binDeps [bin]
synopsis <- interpretPartial target $ getPkgData Synopsis
putSuccess $ renderBox
[ "Successfully built program '"
++ pkgNameString pkg ++ "' (" ++ show stage ++ ")."
, "Executable: " ++ bin
, "Package synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]
windows <- windowsHost
if windows
then buildBinary target bin -- We don't build wrappers on Windows
else case find ((== target) . fst) wrappers of
Nothing -> buildBinary target bin -- No wrapper found
Just (_, wrapper) -> do
wrappedBin <- moveToLib bin
buildBinary target wrappedBin
buildWrapper target wrapper bin wrappedBin
-- Replace programInplacePath with programInplaceLibPath in a given path
moveToLib :: FilePath -> Action FilePath
moveToLib path = case stripPrefix programInplacePath path of
Just suffix -> return $ programInplaceLibPath ++ suffix
Nothing -> putError $ "moveToLib: cannot move " ++ path
buildWrapper :: PartialTarget -> Wrapper -> FilePath -> FilePath -> Action ()
buildWrapper target @ (PartialTarget stage pkg) wrapper wrapperPath binPath = do
contents <- interpretPartial target $ wrapper binPath
writeFileChanged wrapperPath contents
() <- cmd "chmod +x " [wrapperPath]
putSuccess $ "| Successfully created wrapper for '" ++ pkgNameString pkg
++ "' (" ++ show stage ++ ")."
-- TODO: Get rid of the Paths_hsc2hs.o hack.
-- TODO: Do we need to consider other ways when building programs?
buildBinary :: PartialTarget -> FilePath -> Action ()
buildBinary target @ (PartialTarget stage pkg) bin = do
let path = targetPath stage pkg
buildPath = path -/- "build"
cSrcs <- cSources target -- TODO: remove code duplication (Library.hs)
hSrcs <- hSources target
let cObjs = [ buildPath -/- src -<.> osuf vanilla | src <- cSrcs ]
hObjs = [ buildPath -/- src <.> osuf vanilla | src <- hSrcs ]
++ [ buildPath -/- "Paths_hsc2hs.o" | pkg == hsc2hs ]
++ [ buildPath -/- "Paths_haddock.o" | pkg == haddock ]
objs = cObjs ++ hObjs
ways <- interpretPartial target getWays
depNames <- interpretPartial target $ getPkgDataList TransitiveDepNames
let libStage = min stage Stage1 -- libraries are built only in Stage0/1
libTarget = PartialTarget libStage pkg
pkgs <- interpretPartial libTarget getPackages
ghciFlag <- interpretPartial libTarget $ getPkgData BuildGhciLib
let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
ghci = ghciFlag == "YES" && stage == Stage1
libs <- fmap concat . forM deps $ \dep -> do
let depTarget = PartialTarget libStage dep
compId <- interpretPartial depTarget $ getPkgData ComponentId
libFiles <- fmap concat . forM ways $ \way -> do
libFile <- pkgLibraryFile libStage dep compId way
lib0File <- pkgLibraryFile libStage dep (compId ++ "-0") way
dll0 <- needDll0 libStage dep
return $ [ libFile ] ++ [ lib0File | dll0 ]
return $ libFiles ++ [ pkgGhciLibraryFile libStage dep compId | ghci ]
let binDeps = if pkg == ghcCabal && stage == Stage0
then [ pkgPath pkg -/- src <.> "hs" | src <- hSrcs ]
else objs
need $ binDeps ++ libs
build $ fullTargetWithWay target (Ghc stage) vanilla binDeps [bin]
synopsis <- interpretPartial target $ getPkgData Synopsis
putSuccess $ renderBox
[ "Successfully built program '"
++ pkgNameString pkg ++ "' (" ++ show stage ++ ")."
, "Executable: " ++ bin
, "Package synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]
module Rules.Wrappers.Ghc (ghcWrapper) where
import Base
import Expression
import Oracles
ghcWrapper :: FilePath -> Expr String
ghcWrapper program = do
lift $ need [sourcePath -/- "Rules/Wrappers/Ghc.hs"]
top <- getSetting GhcSourcePath
return $ unlines
[ "#!/bin/bash"
, "exec " ++ (top -/- program)
++ " -B" ++ (top -/- takeDirectory program) ++ " ${1+\"$@\"}" ]
......@@ -39,7 +39,7 @@ instance Monoid a => Monoid (ReaderT Target Action a) where
-- PartialTarget is a partially constructed Target with fields Stage and
-- Package only. PartialTarget's are used for generating build rules.
data PartialTarget = PartialTarget Stage Package deriving Show
data PartialTarget = PartialTarget Stage Package deriving (Eq, Show)
-- Convert PartialTarget to Target assuming that unknown fields won't be used.
fromPartial :: PartialTarget -> Target
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment