summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Biz/Bild.hs118
1 files 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
</ pure
Target
{ builder = Local <| user,
+ wrapper = Nothing,
compiler = Ghc,
compilerFlags =
map
@@ -435,6 +456,7 @@ analyze hmap ns = case Map.lookup ns hmap of
</ pure
Target
{ sysdeps = Set.empty,
+ wrapper = Nothing,
compiler = Sbcl,
compilerFlags =
map
@@ -460,6 +482,7 @@ analyze hmap ns = case Map.lookup ns hmap of
</ pure
Target
{ langdeps = Set.empty,
+ wrapper = Nothing,
sysdeps = Set.empty,
compiler = NixBuild,
compilerFlags =
@@ -494,6 +517,18 @@ analyze hmap ns = case Map.lookup ns hmap of
],
builder = Local user,
outPath = outToPath out,
+ wrapper =
+ Just <| Text.pack
+ <| joinWith
+ "\n"
+ [ "#!/usr/bin/env bash",
+ "guile -C \""
+ <> root </> intdir
+ <> "\" -e main "
+ <> "-s "
+ <> Namespace.toPath namespace
+ <> " \"$@\""
+ ],
..
}
Namespace.Rs -> do
@@ -502,6 +537,7 @@ analyze hmap ns = case Map.lookup ns hmap of
</ pure
Target
{ langdeps = Set.empty,
+ wrapper = Nothing,
sysdeps = Set.empty,
compiler = Rustc,
compilerFlags = map Text.pack [path, "-o", root </> 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 10:29:33 +0000