diff options
| -rw-r--r-- | Biz/Bild.hs | 252 | ||||
| -rw-r--r-- | Biz/Log.hs | 4 |
2 files changed, 125 insertions, 131 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 0489185..b23a8ff 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -113,7 +113,6 @@ import Data.Conduit ((.|)) import qualified Data.Conduit as Conduit import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.Process as Conduit -import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.String as String @@ -160,7 +159,7 @@ move args = printOrBuild :: [Target] -> IO [ExitCode] printOrBuild targets | args `Cli.has` Cli.longOption "json" = - traverse_ putJSON targets >> pure [Exit.ExitSuccess] + Log.wipe >> traverse_ putJSON targets >> pure [Exit.ExitSuccess] | otherwise = do root <- Env.getEnv "BIZ_ROOT" createHier root @@ -300,143 +299,134 @@ analyze path = do let contentLines = Text.lines content root <- Env.getEnv "BIZ_ROOT" absPath <- Dir.makeAbsolute path + user <- Env.getEnv "USER" /> Text.pack + host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME" Log.info ["bild", "analyze", str path] - let ns = - if "hs" `List.isSuffixOf` path - then Namespace.fromHaskellContent <| Text.unpack content - else Namespace.fromPath root absPath - case ns of + case Namespace.fromPath root absPath of Nothing -> Log.warn ["bild", "analyze", str path, "could not find namespace"] >> Log.br >> pure Nothing - Just namespace@(Namespace _ ext) -> - Just </ do - user <- Env.getEnv "USER" /> Text.pack - host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME" - let nada = - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = Copy, - out = Nothing, - builder = user <> "@localhost", - .. - } - case ext of - -- basically we don't support building these - Namespace.Css -> pure nada - Namespace.Json -> pure nada - Namespace.Keys -> pure nada - Namespace.Md -> pure nada - Namespace.None -> pure nada - Namespace.Py -> pure nada - Namespace.Sh -> pure nada - Namespace.C -> do - 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", - .. - } - Namespace.Hs -> do - langdeps <- detectHaskellImports contentLines - let out = + Just namespace@(Namespace _ ext) -> case ext of + -- basically we don't support building these + Namespace.Css -> pure Nothing + Namespace.Json -> pure Nothing + Namespace.Keys -> pure Nothing + Namespace.Md -> pure Nothing + Namespace.None -> pure Nothing + Namespace.Py -> pure Nothing + Namespace.Sh -> pure Nothing + Namespace.C -> + Just + </ pure + Target + { langdeps = Set.empty, -- c has no lang deps...? + sysdeps = contentLines /> Text.unpack - /> Regex.match (metaOut "--") + /> Regex.match (metaSys "//") |> catMaybes - |> head - pure - Target - { builder = user <> "@localhost", - compiler = detectGhcCompiler out, - sysdeps = - contentLines - /> Text.unpack - /> Regex.match (metaSys "--") - |> catMaybes - |> Set.fromList, - .. - } - Namespace.Lisp -> do - langdeps <- detectLispImports contentLines - pure - Target - { sysdeps = Set.empty, - compiler = Sbcl, - out = - contentLines - /> Text.unpack - /> Regex.match (metaOut ";;") - |> catMaybes - |> head, - builder = user <> "@localhost", - .. - } - Namespace.Nix -> - 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" - ], - .. - } - Namespace.Scm -> do - pure - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = Guile, - out = - contentLines - /> Text.unpack - /> Regex.match (metaOut ";;") - |> catMaybes - |> head, - builder = user <> "@localhost", - .. - } - Namespace.Rs -> do - pure - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = Rustc, - out = - contentLines - /> Text.unpack - /> Regex.match (metaOut "//") - |> catMaybes - |> head, - builder = user <> "@localhost", - .. - } + |> Set.fromList, + compiler = Gcc, + out = + contentLines + /> Text.unpack + /> Regex.match (metaOut "//" <|> metaLib "//") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } + Namespace.Hs -> do + langdeps <- detectHaskellImports contentLines + let out = + contentLines + /> Text.unpack + /> Regex.match (metaOut "--") + |> catMaybes + |> head + Just + </ pure + Target + { builder = user <> "@localhost", + compiler = detectGhcCompiler out, + sysdeps = + contentLines + /> Text.unpack + /> Regex.match (metaSys "--") + |> catMaybes + |> Set.fromList, + .. + } + Namespace.Lisp -> do + langdeps <- detectLispImports contentLines + Just + </ pure + Target + { sysdeps = Set.empty, + compiler = Sbcl, + out = + contentLines + /> Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } + Namespace.Nix -> + 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" + ], + .. + } + Namespace.Scm -> do + Just + </ pure + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = Guile, + out = + contentLines + /> Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } + Namespace.Rs -> do + Just + </ pure + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = Rustc, + out = + contentLines + /> Text.unpack + /> Regex.match (metaOut "//") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } where detectHaskellImports :: [Text] -> IO (Set Dep) detectHaskellImports contentLines = do @@ -9,6 +9,7 @@ module Biz.Log info, warn, fail, + wipe, -- * Debugging mark, @@ -72,6 +73,9 @@ gap = ": " br :: IO () br = Rainbow.hPutChunks stderr ["\n"] >> IO.hFlush stderr +wipe :: IO () +wipe = hPutStr stderr ("\r" :: Text) >> IO.hFlush stderr + good, pass, info, warn, fail :: [Text] -> IO () good = msg Good pass = msg Pass |