summaryrefslogtreecommitdiff
path: root/Biz/Bild.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Biz/Bild.hs')
-rw-r--r--Biz/Bild.hs285
1 files changed, 166 insertions, 119 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 68ae588..ab6f5bb 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -7,6 +7,8 @@
-- | A general purpose build tool.
--
-- : out bild
+-- : dep conduit
+-- : dep conduit-extra
-- : dep docopt
-- : dep regex-applicative
-- : dep rainbow
@@ -124,16 +126,21 @@ 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
+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.String as String
import qualified Data.Text as Text
-import Rainbow (Chunk, chunk, fore, green, putChunkLn, red)
+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
import System.FilePath ((</>))
-import qualified System.Process as Process
+import qualified System.IO as IO
import qualified Text.Regex.Applicative as Regex
import qualified Prelude
@@ -142,7 +149,8 @@ main = Cli.main <| Cli.Plan help move test
where
test = Test.group "Biz.Bild" [Test.unit "id" <| 1 @=? (1 :: Integer)]
move args =
- mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
+ IO.hSetBuffering stdout IO.NoBuffering
+ >> mapM getNamespace (Cli.getAllArgs args (Cli.argument "target"))
/> catMaybes
/> filter isBuildableNs
>>= mapM analyze
@@ -160,8 +168,7 @@ bild
Usage:
bild test
- bild --help
- bild [--test] [--loud] <target>...
+ bild [options] <target>...
Options:
--test Run tests on a target after building.
@@ -311,17 +318,17 @@ isFailure (Exit.ExitFailure _) = True
isFailure Exit.ExitSuccess = False
build :: Bool -> Bool -> Target -> IO Exit.ExitCode
-build andTest loud target@Target {..} = do
+build andTest loud Target {..} = do
root <- Env.getEnv "BIZ_ROOT"
case compiler of
GhcExe -> do
- putStrLn <| "bild: dev: ghc-exe: " <> Namespace.toPath namespace
+ msg Info ["bild", "dev", "ghc-exe", nschunk namespace]
let outDir = root </> "_/bild/dev/bin"
Dir.createDirectoryIfMissing True outDir
- putText <| "bild: dev: bilder: " <> Text.pack builder
exitcode <-
proc
loud
+ namespace
"ghc"
[ "-Werror",
"-i" <> root,
@@ -336,131 +343,171 @@ build andTest loud target@Target {..} = do
"-o",
outDir </> out
]
- putChunkLn <| fore green <| "bilt: " <> nschunk namespace
- when andTest <| do
- Process.readProcessWithExitCode (outDir </> out) ["test"] "" >>= \case
- (Exit.ExitSuccess, _, _) ->
- putChunkLn <| fore green <| "test: " <> nschunk namespace
- (Exit.ExitFailure _, stdout_, stderr_) -> do
- putChunkLn <| fore red <| "test: " <> nschunk namespace
- when (stdout_ /= mempty) <| putStr stdout_
- when (stderr_ /= mempty) <| putStr stderr_
- return exitcode
+ if andTest
+ then
+ run
+ <| Proc
+ { loud = loud,
+ cmd = outDir </> out,
+ args = ["test"],
+ ns = namespace,
+ onFailure = msg Fail ["test", nschunk namespace] >> br,
+ onSuccess = msg Pass ["test", nschunk namespace] >> br
+ }
+ else return exitcode
GhcLib -> do
- putStrLn <| "bild: dev: ghc-lib: " <> Namespace.toPath namespace
- putText <| "bild: dev: bilder: " <> Text.pack builder
- exitcode <-
- proc
- loud
- "ghc"
- [ "-Werror",
- "-i" <> root,
- "-odir",
- root </> "_/bild/int",
- "-hidir",
- root </> "_/bild/int",
- "--make",
- path
- ]
- putChunkLn <| fore green <| "bilt: " <> nschunk namespace
- return exitcode
+ msg Info ["bild", "dev", "ghc-lib", nschunk namespace]
+ proc
+ loud
+ namespace
+ "ghc"
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> "_/bild/int",
+ "-hidir",
+ root </> "_/bild/int",
+ "--make",
+ path
+ ]
GhcjsExe -> do
- putStrLn <| "bild: dev: ghcjs-exe: " <> Namespace.toPath namespace
+ msg Info ["bild", "dev", "ghcjs-exe", nschunk namespace]
let outDir = root </> "_/bild/dev/static"
Dir.createDirectoryIfMissing True outDir
- putText <| "bild: dev: local: " <> Text.pack builder
- exitcode <-
- proc
- loud
- "ghcjs"
- [ "-Werror",
- "-i" <> root,
- "-odir",
- root </> "_/bild/int",
- "-hidir",
- root </> "_/bild/int",
- "--make",
- path,
- "-main-is",
- Namespace.toHaskellModule namespace,
- "-o",
- outDir </> out
- ]
- putChunkLn <| fore green <| "bilt: " <> nschunk namespace
- return exitcode
+ proc
+ loud
+ namespace
+ "ghcjs"
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> "_/bild/int",
+ "-hidir",
+ root </> "_/bild/int",
+ "--make",
+ path,
+ "-main-is",
+ Namespace.toHaskellModule namespace,
+ "-o",
+ outDir </> out
+ ]
GhcjsLib -> do
- putStrLn <| "bild: dev: ghcjs-lib: " <> Namespace.toPath namespace
- putText <| "bild: dev: local: " <> Text.pack builder
- exitcode <-
- proc
- loud
- "ghcjs"
- [ "-Werror",
- "-i" <> root,
- "-odir",
- root </> "_/bild/int",
- "-hidir",
- root </> "_/bild/int",
- "--make",
- path
- ]
- putChunkLn <| fore green <| "bilt: " <> nschunk namespace
- return exitcode
+ msg Info ["bild", "dev", "ghcjs-lib", nschunk namespace]
+ proc
+ loud
+ namespace
+ "ghcjs"
+ [ "-Werror",
+ "-i" <> root,
+ "-odir",
+ root </> "_/bild/int",
+ "-hidir",
+ root </> "_/bild/int",
+ "--make",
+ path
+ ]
Guile -> do
- putStrLn <| "bild: dev: guile: " <> Namespace.toPath namespace
- putText <| "bild: dev: local: " <> Text.pack builder
- putText "bild: guile: TODO"
- putText <| show target
+ msg Warn ["bild", "guile", "TODO", nschunk namespace]
return Exit.ExitSuccess
NixBuild -> do
- putStrLn <| "bild: nix: " <> Namespace.toPath namespace
+ msg
+ Info
+ [ "bild",
+ "nix",
+ if null builder
+ then "local"
+ else builder,
+ nschunk namespace
+ ]
let outDir = root </> "_/bild/nix"
Dir.createDirectoryIfMissing True outDir
- if null builder
- then putText <| "bild: nix: local"
- else
- putText <| "bild: nix: remote: "
- <> Text.pack builder
- exitcode <-
- proc
- loud
- "nix-build"
- [ path,
- "-o",
- outDir </> Namespace.toPath namespace,
- -- Set default arguments to nix functions
- "--arg",
- "bild",
- "import " <> root
- </> "Biz/Bild/Rules.nix"
- <> " { nixpkgs = import "
- <> root
- </> "Biz/Bild/Nixpkgs.nix"
- <> "; }",
- "--arg",
- "lib",
- "(import " <> root </> "Biz/Bild/Nixpkgs.nix).lib",
- "--builders",
- builder
- ]
- putChunkLn <| fore green <| "bilt: " <> nschunk namespace
- return exitcode
+ proc
+ loud
+ namespace
+ "nix-build"
+ [ path,
+ "-o",
+ outDir </> Namespace.toPath namespace,
+ -- Set default arguments to nix functions
+ "--arg",
+ "bild",
+ "import " <> root
+ </> "Biz/Bild/Rules.nix"
+ <> " { nixpkgs = import "
+ <> root
+ </> "Biz/Bild/Nixpkgs.nix"
+ <> "; }",
+ "--arg",
+ "lib",
+ "(import " <> root </> "Biz/Bild/Nixpkgs.nix).lib",
+ "--builders",
+ builder
+ ]
Copy -> do
- putStrLn <| "bild: copy: " <> Namespace.toPath namespace
- putText "bild: copy: TODO"
- putText <| show target
+ msg Warn ["bild", "copy", "TODO", nschunk namespace]
return Exit.ExitSuccess
--- | Run a subprocess, handling output appropriately.
-proc :: Bool -> String -> [String] -> IO Exit.ExitCode
-proc loud cmd args = do
- (exitcode, stdout_, stderr_) <- Process.readProcessWithExitCode cmd args ""
- when loud <| putStr <| stdout_ ++ stderr_
- when (isFailure exitcode) <| putStr <| stdout_ ++ stderr_
- return exitcode
+data Proc = Proc
+ { loud :: Bool,
+ cmd :: String,
+ args :: [String],
+ ns :: Namespace,
+ onFailure :: IO (),
+ onSuccess :: IO ()
+ }
+
+-- | Run a subprocess, streaming output if --loud is set.
+run :: Proc -> IO Exit.ExitCode
+run Proc {..} = do
+ (Conduit.Inherited, stdout_, stderr_, cph) <- Conduit.streamingProcess <| Conduit.proc cmd args
+ exitcode <-
+ if loud
+ then
+ Async.runConcurrently
+ <| Async.Concurrently (puts stdout_)
+ *> (Async.Concurrently <| Conduit.waitForStreamingProcess cph)
+ else Async.runConcurrently <| Async.Concurrently <| Conduit.waitForStreamingProcess cph
+ if isFailure exitcode
+ then puts stderr_ >> onFailure >> return exitcode
+ else onSuccess >> return exitcode
+
+-- | Helper for running a standard bild subprocess.
+proc :: Bool -> Namespace -> String -> [String] -> IO Exit.ExitCode
+proc loud namespace cmd args =
+ run
+ <| Proc
+ { loud = loud,
+ ns = namespace,
+ cmd = cmd,
+ args = args,
+ onFailure = msg Fail ["bild", nschunk namespace] >> br,
+ onSuccess = msg Good ["bild", nschunk namespace] >> 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 -> Chunk
-nschunk = chunk <. Text.pack <. Namespace.toPath
+nschunk :: Namespace -> String
+nschunk = Namespace.toPath
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-11-01 10:30:37 +0000