Add support for wrappers.
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 31 Dec 2015 00:41:00 +0000 (00:41 +0000)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Thu, 31 Dec 2015 00:41:00 +0000 (00:41 +0000)
src/Rules/Program.hs
src/Rules/Wrappers/Ghc.hs [new file with mode: 0644]
src/Target.hs

index 0199071..93c6a97 100644 (file)
@@ -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 ++ "." ]
diff --git a/src/Rules/Wrappers/Ghc.hs b/src/Rules/Wrappers/Ghc.hs
new file mode 100644 (file)
index 0000000..93ceba0
--- /dev/null
@@ -0,0 +1,14 @@
+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+\"$@\"}" ]
index 25967b4..cd22f48 100644 (file)
@@ -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