From 15a6bb53c7aed9cbf6f1a8edb1b8dbbd174cf9f5 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Wed, 3 Aug 2022 10:44:09 -0400
Subject: Add compilerFlags to Target
This moves logic into the analysis step, and allows better auditing because you
can see exactly what flags and command bild will use to compile the target.
---
Biz/Bild.hs | 317 ++++++++++++++++++++++++++++++------------------------------
1 file changed, 160 insertions(+), 157 deletions(-)
(limited to 'Biz')
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index b23a8ff..f23d04a 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -197,8 +197,8 @@ exitSummary exits =
type Dep = String
-data Out = Lib String | Bin String
- deriving (Show)
+data Out = Lib String | Bin String | None
+ deriving (Show, Eq)
instance Aeson.ToJSON Out where
toJSON out = outdir out |> Text.pack |> Aeson.String
@@ -212,11 +212,23 @@ data Compiler
| NixBuild
| Rustc
| Sbcl
- deriving (Eq, Show, Generic, Aeson.ToJSON)
+ deriving (Eq, Show, Generic)
+
+instance Aeson.ToJSON Compiler where
+ toJSON =
+ Aeson.String <. \case
+ Copy -> "cp"
+ Gcc -> "gcc"
+ GhcLib -> "ghc"
+ GhcExe -> "ghc"
+ Guile -> "guile"
+ NixBuild -> "nix-build"
+ Rustc -> "rustc"
+ Sbcl -> "sbcl"
data Target = Target
{ -- | Output name
- out :: Maybe Out,
+ out :: Out,
-- | Fully qualified namespace partitioned by '.'
namespace :: Namespace,
-- | Absolute path to file
@@ -228,7 +240,9 @@ data Target = Target
-- | Which compiler should we use?
compiler :: Compiler,
-- | Where is this machine being built? Schema: user@location
- builder :: Text
+ builder :: Text,
+ -- | Flags and arguments passed to 'Compiler' when building
+ compilerFlags :: [Text]
}
deriving (Show, Generic, Aeson.ToJSON)
@@ -264,6 +278,7 @@ outdir :: Out -> String
outdir = \case
Bin o -> "_/bin" </> o
Lib o -> "_/lib" </> o
+ None -> mempty
intdir, nixdir, vardir :: String
intdir = "_/int"
@@ -316,25 +331,41 @@ analyze path = do
Namespace.None -> pure Nothing
Namespace.Py -> pure Nothing
Namespace.Sh -> pure Nothing
- Namespace.C ->
+ Namespace.C -> do
+ let out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut "//" <|> metaLib "//")
+ |> catMaybes
+ |> head
+ |> fromMaybe None
+ let sysdeps =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaSys "//")
+ |> catMaybes
+ |> Set.fromList
+ guileFlags <-
+ if "guile_3_0" `elem` sysdeps
+ then
+ Process.readProcess "guile-config" ["compile"] ""
+ /> String.words
+ /> (++ ["-shared", "-fPIC"])
+ /> map Text.pack
+ else pure mempty
Just
</ pure
Target
{ langdeps = Set.empty, -- c has no lang deps...?
- sysdeps =
- contentLines
- /> Text.unpack
- /> Regex.match (metaSys "//")
- |> catMaybes
- |> Set.fromList,
compiler = Gcc,
- out =
- contentLines
- /> Text.unpack
- /> Regex.match (metaOut "//" <|> metaLib "//")
- |> catMaybes
- |> head,
builder = user <> "@localhost",
+ compilerFlags =
+ concat
+ [ [o, dir, Text.pack absPath] ++ guileFlags
+ | let outable = out /= None,
+ o <- outable ?: (["-o"], []),
+ dir <- outable ?: ([Text.pack <| root </> outdir out], [])
+ ],
..
}
Namespace.Hs -> do
@@ -345,11 +376,34 @@ analyze path = do
/> Regex.match (metaOut "--")
|> catMaybes
|> head
+ |> fromMaybe None
Just
</ pure
Target
{ builder = user <> "@localhost",
compiler = detectGhcCompiler out,
+ compilerFlags =
+ map
+ Text.pack
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> intdir,
+ "-hidir",
+ root </> intdir,
+ "--make",
+ path
+ ]
+ ++ (out /= None)
+ ?: ( map
+ Text.pack
+ [ "-main-is",
+ Namespace.toHaskellModule namespace,
+ "-o",
+ root </> outdir out
+ ],
+ []
+ ),
sysdeps =
contentLines
/> Text.unpack
@@ -359,71 +413,103 @@ analyze path = do
..
}
Namespace.Lisp -> do
+ let out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut ";;")
+ |> catMaybes
+ |> head
+ |> fromMaybe None
langdeps <- detectLispImports contentLines
Just
</ pure
Target
{ sysdeps = Set.empty,
compiler = Sbcl,
- out =
- contentLines
- /> Text.unpack
- /> Regex.match (metaOut ";;")
- |> catMaybes
- |> head,
+ compilerFlags =
+ map
+ Text.pack
+ [ "--load",
+ path,
+ "--eval",
+ "(require :asdf)",
+ "--eval",
+ "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out) <> "\" :toplevel #'main :executable t)"
+ ],
builder = user <> "@localhost",
..
}
- Namespace.Nix ->
+ Namespace.Nix -> do
+ let builder =
+ (host == "lithium")
+ ?: ( "local",
+ Text.concat
+ [ "ssh://",
+ user,
+ "@dev.simatime.com?ssh-key=/home/",
+ user,
+ "/.ssh/id_rsa"
+ ]
+ )
Just
</ pure
Target
{ langdeps = Set.empty,
sysdeps = Set.empty,
compiler = NixBuild,
- out = Nothing,
- builder =
- if host == "lithium"
- then mempty
- else
- Text.concat
- [ "ssh://",
- user,
- "@dev.simatime.com?ssh-key=/home/",
- user,
- "/.ssh/id_rsa"
- ],
+ compilerFlags =
+ map
+ Text.pack
+ [ path,
+ "--out-link",
+ root </> nixdir </> Namespace.toPath namespace,
+ "--builders",
+ Text.unpack builder
+ ],
+ out = None,
..
}
Namespace.Scm -> do
+ let out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut ";;")
+ |> catMaybes
+ |> head
+ |> fromMaybe None
Just
</ pure
Target
{ langdeps = Set.empty,
sysdeps = Set.empty,
compiler = Guile,
- out =
- contentLines
- /> Text.unpack
- /> Regex.match (metaOut ";;")
- |> catMaybes
- |> head,
+ compilerFlags =
+ map
+ Text.pack
+ [ "compile",
+ "--r7rs",
+ "--load-path=" ++ root,
+ "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
+ path
+ ],
builder = user <> "@localhost",
..
}
Namespace.Rs -> do
+ let out =
+ contentLines
+ /> Text.unpack
+ /> Regex.match (metaOut "//")
+ |> catMaybes
+ |> head
+ |> fromMaybe None
Just
</ pure
Target
{ langdeps = Set.empty,
sysdeps = Set.empty,
compiler = Rustc,
- out =
- contentLines
- /> Text.unpack
- /> Regex.match (metaOut "//")
- |> catMaybes
- |> head,
+ compilerFlags = map Text.pack [path, "-o", root </> outdir out],
builder = user <> "@localhost",
..
}
@@ -463,10 +549,11 @@ ghcPkgFindModule acc m = do
-- | Some rules for detecting the how to compile a ghc module. If there is an
-- out, then we know it's some Exe, otherwise it's a Lib.
-detectGhcCompiler :: Maybe Out -> Compiler
+detectGhcCompiler :: Out -> Compiler
detectGhcCompiler = \case
- Just _ -> GhcExe
- Nothing -> GhcLib
+ Bin _ -> GhcExe
+ Lib _ -> GhcLib
+ None -> GhcLib
isFailure :: Exit.ExitCode -> Bool
isFailure (Exit.ExitFailure _) = True
@@ -480,11 +567,10 @@ test :: Bool -> Target -> IO Exit.ExitCode
test loud Target {..} = case compiler of
GhcExe -> do
root <- Env.getEnv "BIZ_ROOT"
- let o = Maybe.fromJust out
run
<| Proc
{ loud = loud,
- cmd = root </> outdir o,
+ cmd = root </> outdir out,
args = ["test"],
ns = namespace,
onFailure = Log.fail ["test", nschunk namespace] >> Log.br,
@@ -499,45 +585,16 @@ build :: Bool -> Bool -> Target -> IO Exit.ExitCode
build andTest loud target@Target {..} = do
root <- Env.getEnv "BIZ_ROOT"
case compiler of
- Gcc -> case out of
- Just ou -> case ou of
- Bin _ -> do
- Log.info ["bild", "bin", "gcc", nschunk namespace]
- let baseFlags = ["-o", root </> outdir ou, path]
- proc loud namespace "gcc" baseFlags
- Lib _ -> do
- Log.info ["bild", "lib", "gcc", nschunk namespace]
- let baseFlags = ["-o", root </> outdir ou, path]
- if "guile_3_0" `elem` sysdeps
- then do
- compileFlags <-
- Process.readProcess "guile-config" ["compile"] ""
- /> String.words
- compileFlags <> baseFlags <> ["-shared", "-fPIC"]
- |> proc loud namespace "gcc"
- else proc loud namespace "gcc" baseFlags
- Nothing -> Exit.die "no bin or lib found"
+ Gcc ->
+ Log.info ["bild", label, "gcc", nschunk namespace]
+ >> proc loud namespace "gcc" compilerFlags
+ where
+ label = case out of
+ Bin _ -> "bin"
+ _ -> "lib"
GhcExe -> do
Log.info ["bild", "dev", "ghc-exe", nschunk namespace]
- let o = Maybe.fromJust out
- exitcode <-
- proc
- loud
- namespace
- "ghc"
- [ "-Werror",
- "-i" <> root,
- "-odir",
- root </> intdir,
- "-hidir",
- root </> intdir,
- "--make",
- path,
- "-main-is",
- Namespace.toHaskellModule namespace,
- "-o",
- root </> outdir o
- ]
+ exitcode <- proc loud namespace "ghc" compilerFlags
if andTest && isSuccess exitcode
then test loud target
else pure exitcode
@@ -547,32 +604,13 @@ build andTest loud target@Target {..} = do
loud
namespace
"ghc"
- [ "-Werror",
- "-i" <> root,
- "-odir",
- root </> intdir,
- "-hidir",
- root </> intdir,
- "--make",
- path
- ]
+ compilerFlags
Guile -> do
Log.info ["bild", "dev", "guile", nschunk namespace]
- _ <-
- proc
- loud
- namespace
- "guild"
- [ "compile",
- "--r7rs",
- "--load-path=" ++ root,
- "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
- path
- ]
- when (isJust out) <| do
- let o = Maybe.fromJust out
+ _ <- proc loud namespace "guild" compilerFlags
+ when (out /= None) <| do
writeFile
- (root </> outdir o)
+ (root </> outdir out)
<| Text.pack
<| joinWith
"\n"
@@ -584,56 +622,21 @@ build andTest loud target@Target {..} = do
<> Namespace.toPath namespace
<> " \"$@\""
]
- p <- Dir.getPermissions <| root </> outdir o
- Dir.setPermissions (root </> outdir o) (Dir.setOwnerExecutable True p)
+ p <- Dir.getPermissions <| root </> outdir out
+ Dir.setPermissions (root </> outdir out) (Dir.setOwnerExecutable True p)
pure Exit.ExitSuccess
NixBuild -> do
- Log.info
- [ "bild",
- "nix",
- if Text.null builder
- then "local"
- else builder,
- nschunk namespace
- ]
- proc
- loud
- namespace
- "nix-build"
- [ path,
- "--out-link",
- root </> nixdir </> Namespace.toPath namespace,
- "--builders",
- Text.unpack builder
- ]
+ Log.info ["bild", "nix", builder, nschunk namespace]
+ proc loud namespace "nix-build" compilerFlags
Copy -> do
Log.warn ["bild", "copy", "TODO", nschunk namespace]
pure Exit.ExitSuccess
Rustc -> do
Log.info ["bild", "dev", "rust", nschunk namespace]
- let out' = Maybe.fromJust out
- proc
- loud
- namespace
- "rustc"
- [ path,
- "-o",
- root </> outdir out'
- ]
+ proc loud namespace "rustc" compilerFlags
Sbcl -> do
Log.info ["bild", "dev", "lisp", nschunk namespace]
- let out' = Maybe.fromJust out
- proc
- loud
- namespace
- "sbcl"
- [ "--load",
- path,
- "--eval",
- "(require :asdf)",
- "--eval",
- "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out') <> "\" :toplevel #'main :executable t)"
- ]
+ proc loud namespace "sbcl" compilerFlags
data Proc = Proc
{ loud :: Bool,
@@ -663,14 +666,14 @@ run Proc {..} = do
else onSuccess >> pure exitcode
-- | Helper for running a standard bild subprocess.
-proc :: Bool -> Namespace -> String -> [String] -> IO Exit.ExitCode
+proc :: Bool -> Namespace -> String -> [Text] -> IO Exit.ExitCode
proc loud namespace cmd args =
run
<| Proc
{ loud = loud,
ns = namespace,
cmd = cmd,
- args = args,
+ 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