diff options
| -rw-r--r-- | Biz/Bild.hs | 317 |
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 } |