From 0a003c3303cf01744436cdf94a36bc73f196e353 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 2 Aug 2022 13:40:13 -0400 Subject: Simplify analyze code a bit more --- Biz/Bild.hs | 252 +++++++++++++++++++++++++++++------------------------------- 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 Log.warn ["bild", "analyze", str path, "could not find namespace"] >> Log.br >> pure Nothing - Just namespace@(Namespace _ ext) -> - Just Text.pack - host <- Text.pack "@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 + 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 + "@localhost", + compiler = detectGhcCompiler out, + sysdeps = + contentLines + /> Text.unpack + /> Regex.match (metaSys "--") + |> catMaybes + |> Set.fromList, + .. + } + Namespace.Lisp -> do + langdeps <- detectLispImports contentLines + Just + Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } + Namespace.Nix -> + Just + do + Just + Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } + Namespace.Rs -> do + Just + Text.unpack + /> Regex.match (metaOut "//") + |> catMaybes + |> head, + builder = user <> "@localhost", + .. + } where detectHaskellImports :: [Text] -> IO (Set Dep) detectHaskellImports contentLines = do diff --git a/Biz/Log.hs b/Biz/Log.hs index c3362d9..286e00a 100644 --- a/Biz/Log.hs +++ b/Biz/Log.hs @@ -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 -- cgit v1.2.3