From 15a6bb53c7aed9cbf6f1a8edb1b8dbbd174cf9f5 Mon Sep 17 00:00:00 2001 From: Ben Sima 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(-) 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 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 "@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 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 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 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 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