From a60a5264673038eee6709573e7ef5ddb70196b6a Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 9 Aug 2022 10:56:00 -0400 Subject: Use wrapper and compiler fields from Target --- Biz/Bild.hs | 118 ++++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 72 insertions(+), 46 deletions(-) diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 75d012f..a5495f7 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -130,6 +130,7 @@ import qualified System.Environment as Env import qualified System.Exit as Exit import System.FilePath (replaceExtension, ()) import qualified System.IO as IO +import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process import qualified Text.Regex.Applicative as Regex @@ -230,16 +231,21 @@ data Compiler | Sbcl deriving (Eq, Show, Generic) +compilerExe :: IsString a => Compiler -> a +compilerExe = \case + Copy -> "cp" + Gcc -> "gcc" + Ghc -> "ghc" + Guile -> "guild" + NixBuild -> "nix-build" + Rustc -> "rustc" + Sbcl -> "sbcl" + instance Aeson.ToJSON Compiler where - toJSON = - Aeson.String <. \case - Copy -> "cp" - Gcc -> "gcc" - Ghc -> "ghc" - Guile -> "guile" - NixBuild -> "nix-build" - Rustc -> "rustc" - Sbcl -> "sbcl" + toJSON = Aeson.String <. compilerExe + +instance ToNixFlag Compiler where + toNixFlag = compilerExe data Target = Target { -- | Output name @@ -259,7 +265,9 @@ data Target = Target -- | Where is this machine being built? builder :: Builder, -- | Flags and arguments passed to 'Compiler' when building - compilerFlags :: [Text] + compilerFlags :: [Text], + -- | Wrapper script (if necessary) + wrapper :: Maybe Text } deriving (Show, Generic, Aeson.ToJSON) @@ -274,10 +282,13 @@ instance Aeson.ToJSON Builder where toJSON (Local u) = Aeson.String u toJSON (Remote u host) = Aeson.String <| u <> "@" <> host -toNixFlag :: Builder -> String -toNixFlag = \case - Local _ -> "" - Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"] +class ToNixFlag a where + toNixFlag :: a -> String + +instance ToNixFlag Builder where + toNixFlag = \case + Local _ -> "" + Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"] -- | We can't build everything yet... isBuildableNs :: Namespace -> Bool @@ -306,17 +317,25 @@ isBuildableNs = \case ["Biz", "Dragons", "Analysis"] ] +-- | The default output directory. This is not IO because I don't want to +-- refactor all of my code right now, but it probably should be. +cab :: FilePath +cab = + Env.lookupEnv "CABDIR" + /> fromMaybe "_" + |> unsafePerformIO + -- | Emulate the *nix hierarchy in the cabdir. outToPath :: Out -> FilePath outToPath = \case - Bin o -> "_/bin" o - Lib o -> "_/lib" o + Bin o -> cab "bin" o + Lib o -> cab "lib" o None -> mempty -intdir, nixdir, vardir :: String -intdir = "_/int" -nixdir = "_/nix" -vardir = "_/var" +intdir, nixdir, vardir :: FilePath +intdir = cab "int" +nixdir = cab "nix" +vardir = cab "var" createHier :: String -> IO () createHier root = @@ -380,6 +399,7 @@ analyze hmap ns = case Map.lookup ns hmap of +> \guileFlags -> Target { langdeps = Set.empty, -- c has no lang deps...? + wrapper = Nothing, compiler = Gcc, builder = Local <| user, compilerFlags = @@ -401,6 +421,7 @@ analyze hmap ns = case Map.lookup ns hmap of root intdir + <> "\" -e main " + <> "-s " + <> Namespace.toPath namespace + <> " \"$@\"" + ], .. } Namespace.Rs -> do @@ -502,6 +537,7 @@ analyze hmap ns = case Map.lookup ns hmap of outToPath out], @@ -596,7 +632,7 @@ build andTest loud analysis = do case compiler of Gcc -> Log.info ["bild", label, "gcc", nschunk namespace] - >> proc loud namespace "gcc" compilerFlags + >> proc loud namespace compiler compilerFlags where label = case out of Bin _ -> "bin" @@ -605,36 +641,26 @@ build andTest loud analysis = do None -> pure Exit.ExitSuccess Bin _ -> do Log.info ["bild", "dev", "ghc-exe", nschunk namespace] - exitcode <- proc loud namespace "ghc" compilerFlags + exitcode <- proc loud namespace compiler compilerFlags if andTest && isSuccess exitcode then test loud target else pure exitcode Lib _ -> do Log.info ["bild", "dev", "ghc-lib", nschunk namespace] - proc loud namespace "ghc" compilerFlags + proc loud namespace compiler compilerFlags Guile -> do Log.info ["bild", "dev", "guile", nschunk namespace] - _ <- proc loud namespace "guild" compilerFlags - (out /= None) ?| do - writeFile - (root outToPath out) - <| Text.pack - <| joinWith - "\n" - [ "#!/usr/bin/env bash", - "guile -C \"" - <> root intdir - <> "\" -e main " - <> "-s " - <> Namespace.toPath namespace - <> " \"$@\"" - ] - p <- Dir.getPermissions <| root outToPath out - Dir.setPermissions (root outToPath out) (Dir.setOwnerExecutable True p) - pure Exit.ExitSuccess + _ <- proc loud namespace compiler compilerFlags + case wrapper of + Nothing -> pure Exit.ExitSuccess + Just content -> do + writeFile (root outToPath out) content + p <- Dir.getPermissions <| root outToPath out + Dir.setPermissions (root outToPath out) (Dir.setOwnerExecutable True p) + pure Exit.ExitSuccess NixBuild -> do Log.info ["bild", "nix", toLog builder, nschunk namespace] - proc loud namespace "nix-build" compilerFlags + proc loud namespace compiler compilerFlags where toLog (Local u) = u toLog (Remote u h) = u <> "@" <> h @@ -643,10 +669,10 @@ build andTest loud analysis = do pure Exit.ExitSuccess Rustc -> do Log.info ["bild", "dev", "rust", nschunk namespace] - proc loud namespace "rustc" compilerFlags + proc loud namespace compiler compilerFlags Sbcl -> do Log.info ["bild", "dev", "lisp", nschunk namespace] - proc loud namespace "sbcl" compilerFlags + proc loud namespace compiler compilerFlags data Proc = Proc { loud :: Bool, @@ -679,13 +705,13 @@ run Proc {..} = *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) -- | Helper for running a standard bild subprocess. -proc :: Bool -> Namespace -> String -> [Text] -> IO Exit.ExitCode +proc :: ToNixFlag a => Bool -> Namespace -> a -> [Text] -> IO Exit.ExitCode proc loud namespace cmd args = run <| Proc { loud = loud, ns = namespace, - cmd = cmd, + cmd = toNixFlag cmd, args = map Text.unpack args, onFailure = Log.fail ["bild", nschunk namespace] >> Log.br, onSuccess = Log.good ["bild", nschunk namespace] >> Log.br -- cgit v1.2.3