Simplify analyze code a bit more

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