From 82dbbc0eed18c86aae1a8f1f92a0c98684e63409 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 26 Jan 2021 19:05:58 -0500 Subject: Create Biz.Log library, extracted from Biz.Bild --- Biz/Bild.hs | 100 ++++++++++++++++++++++++++++-------------------------------- Biz/Lint.hs | 36 +++++++++++----------- Biz/Log.hs | 44 ++++++++++++++++++++++++++ Biz/Test.hs | 4 +++ 4 files changed, 112 insertions(+), 72 deletions(-) create mode 100644 Biz/Log.hs 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 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 [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 -> -- cgit v1.2.3