From 0a003c3303cf01744436cdf94a36bc73f196e353 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
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 </ 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
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