diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Bild.hs | 102 | ||||
| -rw-r--r-- | Biz/Bild.nix | 6 | ||||
| -rw-r--r-- | Biz/Bild/Deps/Haskell.nix | 1 | ||||
| -rw-r--r-- | Biz/Lint.hs | 3 | ||||
| -rw-r--r-- | Biz/Log.hs | 4 |
5 files changed, 66 insertions, 50 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 2dc1e64..a9988d5 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -125,19 +125,20 @@ import qualified Biz.Test as Test import qualified Conduit import qualified Control.Concurrent.Async as Async import qualified Data.Aeson as Aeson -import qualified Data.ByteString as BS +import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Internal as BSI -import qualified Data.ByteString.Lazy as ByteString +import qualified Data.ByteString.Lazy as ByteString.Lazy import qualified Data.Char as Char import Data.Conduit ((.|)) -import qualified Data.Conduit.List as Conduit +import qualified Data.Conduit.Combinators as Conduit import qualified Data.Conduit.Process as Conduit import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO +import qualified Network.HostName as HostName import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit @@ -148,7 +149,7 @@ import qualified System.Process as Process import qualified Text.Regex.Applicative as Regex main :: IO () -main = Cli.main <| Cli.Plan help move test_ pure +main = Cli.Plan help move test_ pure |> Cli.main where test_ = Test.group @@ -189,19 +190,19 @@ test_bildExamples = xs -> all (== Exit.ExitSuccess) xs @=? True move :: Cli.Arguments -> IO () -move args = do - root <- Env.getEnv "BIZ_ROOT" +move args = IO.hSetBuffering stdout IO.NoBuffering - >> pure (Cli.getAllArgs args (Cli.argument "target")) - /> filter (not <. Namespace.isCab) - +> filterM Dir.doesFileExist - +> traverse Dir.makeAbsolute - /> map (Namespace.fromPath root) - /> catMaybes - +> foldM analyze mempty - /> Map.filter (namespace .> isBuildableNs) - +> printOrBuild - +> exitSummary + >> Env.getEnv "BIZ_ROOT" +> \root -> + Cli.getAllArgs args (Cli.argument "target") + |> filter (not <. Namespace.isCab) + |> filterM Dir.doesFileExist + +> traverse Dir.makeAbsolute + /> map (Namespace.fromPath root) + /> catMaybes + +> foldM analyze mempty + /> Map.filter (namespace .> isBuildableNs) + +> printOrBuild + +> exitSummary where printOrBuild :: Analysis -> IO [ExitCode] printOrBuild targets @@ -213,7 +214,7 @@ move args = do build isTest isLoud targets isTest = args `Cli.has` Cli.longOption "test" isLoud = args `Cli.has` Cli.longOption "loud" - putJSON = Aeson.encode .> ByteString.toStrict .> Char8.putStrLn + putJSON = Aeson.encode .> ByteString.Lazy.toStrict .> Char8.putStrLn nixStore :: String nixStore = "/nix/store/00000000000000000000000000000000-" @@ -420,7 +421,7 @@ analyze hmap ns = case Map.lookup ns hmap of root <- Env.getEnv "BIZ_ROOT" let absPath = root </> path user <- Env.getEnv "USER" /> Text.pack - host <- Env.lookupEnv "HOSTNAME" /> fromMaybe "interactive" /> Text.pack + host <- HostName.getHostName /> Text.pack Log.info ["bild", "analyze", str path] let runw cmd args = Process.readProcess cmd args "" /> Text.pack /> Text.words contentLines <- @@ -516,6 +517,7 @@ analyze hmap ns = case Map.lookup ns hmap of packageSet = "ghcWith", compilerFlags = [ "-Werror", + "-threaded", "-i$BIZ_ROOT", "-odir", ".", @@ -798,27 +800,30 @@ data Proc = Proc -- | Run a subprocess, streaming output if --loud is set. run :: Proc -> IO (Exit.ExitCode, ByteString) run Proc {..} = do - loud ?| Log.info ["proc", unwords <| map str <| cmd : args] >> Log.br + IO.hSetBuffering stdout IO.NoBuffering + loud ?| Log.info ["proc", unwords <| map str <| cmd : args] Conduit.proc cmd args |> Conduit.streamingProcess +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> - Conduit.runConduitRes (stdout_ .| Conduit.foldC) - +> \output -> - Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) - *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) - *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) - |> Async.runConcurrently - +> \case - Exit.ExitFailure n -> - puts stderr_ - >> onFailure - >> pure (Exit.ExitFailure n, output) - Exit.ExitSuccess -> - onSuccess - >> pure (Exit.ExitSuccess, output) + (,,) </ Async.Concurrently (Conduit.waitForStreamingProcess hdl) + <*> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) + <*> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) + |> Async.runConcurrently + +> \case + (Exit.ExitFailure n, output, outerr) -> + putStr outerr + >> onFailure + >> pure (Exit.ExitFailure n, output) + (Exit.ExitSuccess, output, _) -> + onSuccess >> pure (Exit.ExitSuccess, output) -- | Helper for running a standard bild subprocess. -proc :: Bool -> Namespace -> String -> [Text] -> IO (Exit.ExitCode, ByteString) +proc :: + Bool -> + Namespace -> + String -> + [Text] -> + IO (Exit.ExitCode, ByteString) proc loud namespace cmd args = Proc { loud = loud, @@ -831,25 +836,31 @@ proc loud namespace cmd args = |> run -- | Helper for printing during a subprocess -puts :: Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> IO () -puts src = Conduit.runConduitRes <| src .| Conduit.mapM_ putStr - --- | Like 'puts' but the output goes to a file. Maybe this should use /tmp by default though? -putsToTmp :: Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> FilePath -> IO () -putsToTmp src filepath = Conduit.runConduitRes <| src .| Conduit.sinkFile filepath +puts :: + Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> + IO ByteString +puts src = + Conduit.runConduitRes + <| src + .| Conduit.iterM (liftIO <. putStr) + .| Conduit.foldC -- | Like 'puts' but logs the output via 'Biz.Log'. -logs :: Namespace -> Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> IO () +logs :: + Namespace -> + Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () -> + IO ByteString logs ns src = Conduit.runConduitRes <| src - .| Conduit.mapM_ - ( BS.filter (/= BSI.c2w '\n') + .| Conduit.iterM + ( ByteString.filter (/= BSI.c2w '\n') .> (\t -> Log.fmt ["info", "bild", nschunk ns, decodeUtf8 t]) - .> Text.take 77 - .> (<> "...\r") + .> Text.take 79 + .> (<> "…\r") .> putStr ) + .| Conduit.foldC nschunk :: Namespace -> Text nschunk = Namespace.toPath .> Text.pack @@ -886,6 +897,7 @@ nixBuild :: Bool -> Target -> IO (Exit.ExitCode, ByteString) nixBuild loud Target {..} = Env.getEnv "BIZ_ROOT" +> \root -> instantiate root |> run +> \case + (_, "") -> panic "instantiate did not produce a drv" (Exit.ExitSuccess, drv) -> drv |> str diff --git a/Biz/Bild.nix b/Biz/Bild.nix index 0391d84..dca1b3b 100644 --- a/Biz/Bild.nix +++ b/Biz/Bild.nix @@ -32,7 +32,7 @@ rec { ghcPackageSetBild = private.ghcWith (hpkgs: with hpkgs; [ aeson async base bytestring conduit conduit-extra containers directory docopt filepath process protolude rainbow regex-applicative split tasty - tasty-hunit tasty-quickcheck text neat-interpolation + tasty-hunit tasty-quickcheck text hostname wai # can remove when removed from Biz.Log ]); @@ -50,14 +50,13 @@ rec { # this is just to get access to ghc-pkg in bild (private.ghcWith (hpkgs: with hpkgs; [])) - /* disable until nixified builds are complete + /* disable until nixified builds are complete */ rustc # c deps gcc gdb valgrind argp-standalone SDL # lisp deps guile (private.sbclWith (p: with p; [asdf alexandria])) # just enough to build Example.lisp - */ ]; # a standard nix build for `bild` - this should be the only hand-written @@ -75,6 +74,7 @@ rec { ${private.ghcPackageSetFull}/lib/ghc-${private.ghcPackageSetFull.version}/package.conf.d \ $out/lib/ghc-${private.ghcPackageSetFull.version} ghc \ + -threaded \ -Werror \ -i. \ --make Biz/Bild.hs \ diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix index d8108d7..066fd86 100644 --- a/Biz/Bild/Deps/Haskell.nix +++ b/Biz/Bild/Deps/Haskell.nix @@ -27,6 +27,7 @@ with hpkgs; hashids haskeline hmacaroons + hostname http-types ixset katip diff --git a/Biz/Lint.hs b/Biz/Lint.hs index b1cc0d4..f9b16d0 100644 --- a/Biz/Lint.hs +++ b/Biz/Lint.hs @@ -14,7 +14,6 @@ import Biz.Namespace (Ext (..), 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.String as String import qualified Data.Text as Text import qualified System.Directory as Directory @@ -153,7 +152,7 @@ run :: Mode -> [FilePath] -> IO [Result] run mode paths = do cwd <- Directory.getCurrentDirectory root <- Environment.getEnv "BIZ_ROOT" - concat </ Async.mapConcurrently (runOne mode root cwd) paths + concat </ traverse (runOne mode root cwd) paths runOne :: Mode -> FilePath -> FilePath -> FilePath -> IO [Result] runOne mode root cwd path_ = results +> traverse_ printResult >> results @@ -10,6 +10,10 @@ -- -- * don't use `br` after `info`, unless verbose mode is requested (--loud flag in bild) -- +-- * always use `br` after `good`, `fail`, and `pass` +-- +-- * often use `br` after `warn`, unless its really unimportant +-- -- * labels should be roughly hierarchical from general->specific module Biz.Log ( Lvl (..), |