summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Biz/Bild.hs100
-rw-r--r--Biz/Lint.hs36
-rw-r--r--Biz/Log.hs44
-rw-r--r--Biz/Test.hs4
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 ->
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 07:23:25 +0000