summaryrefslogtreecommitdiff
path: root/Biz
diff options
context:
space:
mode:
Diffstat (limited to 'Biz')
-rw-r--r--Biz/Bild.hs317
1 files changed, 160 insertions, 157 deletions
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
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 11:32:48 +0000