summaryrefslogtreecommitdiff
path: root/Biz/Bild.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Biz/Bild.hs')
-rw-r--r--Biz/Bild.hs100
1 files changed, 47 insertions, 53 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)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-28 12:36:09 +0000