Create Biz.Log library, extracted from Biz.Bild

4 files changed, 112 insertions, 72 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index ed34009..8a7de48 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -122,9 +122,9 @@ module Biz.Bild where
 
 import Alpha hiding (sym, (<.>))
 import qualified Biz.Cli as Cli
+import qualified Biz.Log as Log
 import Biz.Namespace (Namespace (..))
 import qualified Biz.Namespace as Namespace
-import Biz.Test ((@=?))
 import qualified Biz.Test as Test
 import qualified Control.Concurrent.Async as Async
 import qualified Data.Char as Char
@@ -135,7 +135,6 @@ import qualified Data.Conduit.Process as Conduit
 import qualified Data.List as List
 import qualified Data.String as String
 import qualified Data.Text as Text
-import Rainbow (chunk, fore, green, putChunk, red, white, yellow)
 import qualified System.Directory as Dir
 import qualified System.Environment as Env
 import qualified System.Exit as Exit
@@ -147,19 +146,29 @@ import qualified Prelude
 main :: IO ()
 main = Cli.main <| Cli.Plan help move test
   where
-    test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)]
-    move args =
-      IO.hSetBuffering stdout IO.LineBuffering
-        >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
-        /> catMaybes
-        /> filter isBuildableNs
-        >>= mapM analyze
-        >>= mapM
-          ( build
-              (args `Cli.has` Cli.longOption "test")
-              (args `Cli.has` Cli.longOption "loud")
-          )
-        >>= exitSummary
+    test =
+      Test.group
+        "Biz.Bild"
+        [ Test.unit "can bild bild" <| do
+            let ns = Namespace ["Biz", "Bild"] Namespace.Hs
+            analyze ns >>= build False False >>= \case
+              Exit.ExitFailure _ -> Test.assertFailure "can't bild bild"
+              _ -> pure ()
+        ]
+
+move :: Cli.Arguments -> IO ()
+move args =
+  IO.hSetBuffering stdout IO.NoBuffering
+    >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
+    /> catMaybes
+    /> filter isBuildableNs
+    >>= mapM analyze
+    >>= mapM
+      ( build
+          (args `Cli.has` Cli.longOption "test")
+          (args `Cli.has` Cli.longOption "loud")
+      )
+    >>= exitSummary
 
 help :: Cli.Docopt
 help =
@@ -210,7 +219,7 @@ data Target = Target
     -- | Which compiler should we use?
     compiler :: Compiler,
     -- | Where is this machine being built? Schema: user@location
-    builder :: String
+    builder :: Text
   }
   deriving (Show)
 
@@ -237,7 +246,7 @@ getNamespace s = do
 
 analyze :: Namespace -> IO Target
 analyze namespace@(Namespace.Namespace _ ext) = do
-  user <- Env.getEnv "USER"
+  user <- Env.getEnv "USER" /> Text.pack
   host <- chomp </ readFile "/etc/hostname"
   let path = Namespace.toPath namespace
   case ext of
@@ -266,7 +275,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do
               if host == "lithium"
                 then mempty
                 else
-                  join
+                  Text.concat
                     [ "ssh://",
                       user,
                       "@dev.simatime.com?ssh-key=/home/",
@@ -317,12 +326,16 @@ isFailure :: Exit.ExitCode -> Bool
 isFailure (Exit.ExitFailure _) = True
 isFailure Exit.ExitSuccess = False
 
+isSuccess :: Exit.ExitCode -> Bool
+isSuccess Exit.ExitSuccess = True
+isSuccess _ = False
+
 build :: Bool -> Bool -> Target -> IO Exit.ExitCode
 build andTest loud Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
     GhcExe -> do
-      msg Info ["bild", "dev", "ghc-exe", nschunk namespace]
+      Log.info ["bild", "dev", "ghc-exe", nschunk namespace]
       let outDir = root </> "_/bild/dev/bin"
       Dir.createDirectoryIfMissing True outDir
       exitcode <-
@@ -343,7 +356,7 @@ build andTest loud Target {..} = do
             "-o",
             outDir </> out
           ]
-      if andTest
+      if andTest && isSuccess exitcode
         then
           run
             <| Proc
@@ -351,12 +364,12 @@ build andTest loud Target {..} = do
                 cmd = outDir </> out,
                 args = ["test"],
                 ns = namespace,
-                onFailure = msg Fail ["test", nschunk namespace] >> br,
-                onSuccess = msg Pass ["test", nschunk namespace] >> br
+                onFailure = Log.fail ["test", nschunk namespace] >> Log.br,
+                onSuccess = Log.pass ["test", nschunk namespace] >> Log.br
               }
         else return exitcode
     GhcLib -> do
-      msg Info ["bild", "dev", "ghc-lib", nschunk namespace]
+      Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
       proc
         loud
         namespace
@@ -371,7 +384,7 @@ build andTest loud Target {..} = do
           path
         ]
     GhcjsExe -> do
-      msg Info ["bild", "dev", "ghcjs-exe", nschunk namespace]
+      Log.info ["bild", "dev", "ghcjs-exe", nschunk namespace]
       let outDir = root </> "_/bild/dev/static"
       Dir.createDirectoryIfMissing True outDir
       proc
@@ -392,7 +405,7 @@ build andTest loud Target {..} = do
           outDir </> out
         ]
     GhcjsLib -> do
-      msg Info ["bild", "dev", "ghcjs-lib", nschunk namespace]
+      Log.info ["bild", "dev", "ghcjs-lib", nschunk namespace]
       proc
         loud
         namespace
@@ -407,14 +420,13 @@ build andTest loud Target {..} = do
           path
         ]
     Guile -> do
-      msg Warn ["bild", "guile", "TODO", nschunk namespace]
+      Log.warn ["bild", "guile", "TODO", nschunk namespace]
       return Exit.ExitSuccess
     NixBuild -> do
-      msg
-        Info
+      Log.info
         [ "bild",
           "nix",
-          if null builder
+          if Text.null builder
             then "local"
             else builder,
           nschunk namespace
@@ -441,10 +453,10 @@ build andTest loud Target {..} = do
           "lib",
           "(import " <> root </> "Biz/Bild/Nixpkgs.nix).lib",
           "--builders",
-          builder
+          Text.unpack builder
         ]
     Copy -> do
-      msg Warn ["bild", "copy", "TODO", nschunk namespace]
+      Log.warn ["bild", "copy", "TODO", nschunk namespace]
       return Exit.ExitSuccess
 
 data Proc = Proc
@@ -480,34 +492,16 @@ proc loud namespace cmd args =
         ns = namespace,
         cmd = cmd,
         args = args,
-        onFailure = msg Fail ["bild", nschunk namespace] >> br,
-        onSuccess = msg Good ["bild", nschunk namespace] >> br
+        onFailure = Log.fail ["bild", nschunk namespace] >> Log.br,
+        onSuccess = Log.good ["bild", nschunk namespace] >> Log.br
       }
 
-data Lvl = Good | Pass | Info | Warn | Fail
-
-msg :: Lvl -> [String] -> IO ()
-msg lvl labels = putChunk <| fore color <| clear <> txt <> "\r"
-  where
-    txt = chunk <| Text.pack <| joinWith gap (label : labels)
-    (color, label) = case lvl of
-      Good -> (green, "good")
-      Pass -> (green, "pass")
-      Info -> (white, "info")
-      Warn -> (yellow, "warn")
-      Fail -> (red, "fail")
-    gap = ":  "
-    clear = "\ESC[2K"
-
-br :: IO ()
-br = putChunk "\n"
-
 -- | Helper for printing during a subprocess
 puts :: Conduit.ConduitM () ByteString IO () -> IO ()
 puts thing = Conduit.runConduit <| thing .| Conduit.mapM_ putStr
 
-nschunk :: Namespace -> String
-nschunk = Namespace.toPath
+nschunk :: Namespace -> Text
+nschunk = Namespace.toPath .> Text.pack
 
 metaDep :: Regex.RE Char Dep
 metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
diff --git a/Biz/Lint.hs b/Biz/Lint.hs
index ccbb393..26d4e6d 100644
--- a/Biz/Lint.hs
+++ b/Biz/Lint.hs
@@ -11,6 +11,7 @@ module Biz.Lint (main) where
 
 import Alpha
 import qualified Biz.Cli as Cli
+import qualified Biz.Log as Log
 import Biz.Namespace (Ext (..), Namespace (..))
 import qualified Biz.Namespace as Namespace
 import Biz.Test ((@=?))
@@ -18,7 +19,6 @@ import qualified Biz.Test as Test
 import qualified Control.Concurrent.Async as Async
 import qualified Data.String as String
 import qualified Data.Text as Text
-import Rainbow (chunk, fore, green, putChunkLn, red, yellow)
 import qualified System.Directory as Directory
 import qualified System.Environment as Environment
 import qualified System.Exit as Exit
@@ -34,7 +34,13 @@ move args = case Cli.getAllArgs args (Cli.argument "file") of
   files -> run (filter notcab files) >>= mapM printResult >>= exit
 
 test :: Test.Tree
-test = Test.group "Biz.Lint" [Test.unit "id" <| 1 @=? 1]
+test =
+  Test.group
+    "Biz.Lint"
+    [ Test.unit "haskell files return two Results" <| do
+        results <- run ["Biz/Lint.hs"]
+        length results @=? 2
+    ]
 
 notcab :: FilePath -> Bool
 notcab ('_' : _) = False
@@ -59,27 +65,19 @@ exit results = Exit.exitWith <| if n > 0 then Exit.ExitFailure n else Exit.ExitS
     bad Ok {status = Bad _} = True
     bad _ = False
 
-schunk = chunk <. Text.pack
-
 printResult :: Result -> IO Result
-printResult r@(Warn err) =
-  (putChunkLn <| fore yellow <| "lint:  warn:  " <> chunk err) >> pure r
+printResult r@(Warn err) = Log.warn ["lint", err] >> Log.br >> pure r
 printResult r@(Ok path_ linter_ (Bad err)) =
-  ( putChunkLn <| fore red <| "lint:  baad:  "
-      <> schunk linter_
-      <> ": "
-      <> schunk path_
-  )
+  Log.fail ["lint", linter_, Text.pack path_]
+    >> Log.br
     >> if err == "" then pure r else putText (Text.pack err) >> pure r
 printResult r@(Ok path_ linter_ Good) =
-  ( putChunkLn <| fore green <| "lint:  good:  "
-      <> schunk linter_
-      <> ":  "
-      <> schunk path_
-  )
+  Log.good ["lint", linter_, Text.pack path_]
+    >> Log.br
     >> pure r
 printResult r@(NoOp path_) =
-  (putText <| "lint:  noop:  " <> Text.pack path_)
+  Log.info ["lint", "noop", Text.pack path_]
+    >> Log.br
     >> pure r
 
 changedFiles :: IO [FilePath]
@@ -91,7 +89,7 @@ changedFiles = mergeBase >>= changed
       String.lines
         </ git ["diff", "--name-only", "--diff-filter=d", mb]
 
-type Linter = String
+type Linter = Text
 
 data Status = Good | Bad String
   deriving (Show)
@@ -126,7 +124,7 @@ runOne root cwd path_ =
 
 lint :: Linter -> [String] -> FilePath -> IO Result
 lint bin args path_ =
-  Process.readProcessWithExitCode bin (args ++ [path_]) "" >>= \case
+  Process.readProcessWithExitCode (Text.unpack bin) (args ++ [path_]) "" >>= \case
     (Exit.ExitSuccess, _, _) -> pure <| Ok path_ bin Good
     (Exit.ExitFailure _, msg, _) ->
       pure <| Ok path_ bin <| Bad msg
diff --git a/Biz/Log.hs b/Biz/Log.hs
new file mode 100644
index 0000000..c713946
--- /dev/null
+++ b/Biz/Log.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Biz.Log
+  ( Lvl (..),
+    good,
+    pass,
+    info,
+    warn,
+    fail,
+    -- | Low-level
+    msg,
+    br,
+  )
+where
+
+import Alpha hiding (pass)
+import qualified Data.Text as Text
+import Rainbow (chunk, fore, green, putChunk, red, white, yellow)
+
+data Lvl = Good | Pass | Info | Warn | Fail
+
+msg :: Lvl -> [Text] -> IO ()
+msg lvl labels = putChunk <| fore color <| clear <> txt <> "\r"
+  where
+    txt = chunk <| Text.intercalate gap (label : labels)
+    (color, label) = case lvl of
+      Good -> (green, "good")
+      Pass -> (green, "pass")
+      Info -> (white, "info")
+      Warn -> (yellow, "warn")
+      Fail -> (red, "fail")
+    gap = ":  "
+    clear = "\ESC[2K"
+
+br :: IO ()
+br = putChunk "\n"
+
+good, pass, info, warn, fail :: [Text] -> IO ()
+good = msg Good
+pass = msg Pass
+info = msg Info
+warn = msg Warn
+fail = msg Fail
diff --git a/Biz/Test.hs b/Biz/Test.hs
index 7571008..db71831 100644
--- a/Biz/Test.hs
+++ b/Biz/Test.hs
@@ -9,6 +9,7 @@ module Biz.Test
     unit,
     prop,
     with,
+    assertFailure,
     (@=?),
     (@?=),
     (@?!=),
@@ -32,6 +33,9 @@ unit = HUnit.testCase
 prop :: QuickCheck.Testable a => Tasty.TestName -> a -> Tasty.TestTree
 prop = QuickCheck.testProperty
 
+assertFailure :: String -> HUnit.Assertion
+assertFailure = HUnit.assertFailure
+
 with ::
   -- | Startup
   IO a ->