diff options
Diffstat (limited to 'Omni/Bild.hs')
| -rw-r--r--[-rwxr-xr-x] | Omni/Bild.hs | 1214 |
1 files changed, 853 insertions, 361 deletions
diff --git a/Omni/Bild.hs b/Omni/Bild.hs index 967d143..e1f5c46 100755..100644 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -119,6 +119,9 @@ module Omni.Bild where import Alpha hiding (sym, (<.>)) import qualified Conduit import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.QSemN as QSemN +import Control.Concurrent.STM (TQueue, TVar, modifyTVar', newTQueue, newTVar, readTVar, readTVarIO, tryReadTQueue, writeTQueue) +import qualified Control.Exception as Exception import qualified Data.Aeson as Aeson import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as Char8 @@ -128,6 +131,9 @@ import qualified Data.Char as Char import Data.Conduit ((.|)) import qualified Data.Conduit.Combinators as Conduit import qualified Data.Conduit.Process as Conduit +import Data.Graph (SCC (..), stronglyConnComp) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) +import Data.List (partition) import qualified Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set @@ -136,9 +142,11 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified GHC.Conc as GHC import qualified Network.HostName as HostName +import qualified Numeric import qualified Omni.Bild.Meta as Meta import qualified Omni.Cli as Cli import qualified Omni.Log as Log +import qualified Omni.Log.Concurrent as LogC import Omni.Namespace (Namespace (..)) import qualified Omni.Namespace as Namespace import Omni.Test ((@=?)) @@ -146,13 +154,22 @@ import qualified Omni.Test as Test import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit -import System.FilePath (replaceExtension, (</>)) +import System.FilePath (dropExtension, replaceExtension, takeDirectory, (</>)) import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process import qualified System.Timeout as Timeout import qualified Text.Regex.Applicative as Regex +mapConcurrentlyBounded :: Int -> (a -> IO b) -> [a] -> IO [b] +mapConcurrentlyBounded n f xs = do + sem <- QSemN.newQSemN n + Async.forConcurrently xs <| \x -> + Exception.bracket_ + (QSemN.waitQSemN sem 1) + (QSemN.signalQSemN sem 1) + (f x) + main :: IO () main = Cli.Plan help move test_ pure |> Cli.main where @@ -163,19 +180,20 @@ main = Cli.Plan help move test_ pure |> Cli.main test_bildExamples, test_isGitIgnored, test_isGitHook, - test_detectPythonImports + test_detectPythonImports, + test_buildHsModuleGraph ] test_bildBild :: Test.Tree test_bildBild = Test.unit "can bild bild" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute "Omni/Bild.hs" case Namespace.fromPath root path of Nothing -> Test.assertFailure "can't find ns for bild" Just ns -> - analyze mempty ns - +> build False False 1 2 + analyzeAll True [ns] + +> build False True 1 2 +> \case [Exit.ExitFailure _] -> Test.assertFailure "can't bild bild" @@ -185,40 +203,63 @@ test_bildBild = test_bildExamples :: Test.Tree test_bildExamples = Test.unit "can bild examples" <| do - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> ["c", "hs", "lisp", "rs"] |> map ("Omni/Bild/Example." <>) |> traverse Dir.makeAbsolute /> map (Namespace.fromPath root) /> catMaybes - +> foldM analyze mempty - +> build False False 4 1 + +> analyzeAll True + +> build False True 4 1 +> \case [] -> Test.assertFailure "asdf" xs -> all (== Exit.ExitSuccess) xs @=? True move :: Cli.Arguments -> IO () -move args = +move args = do IO.hSetBuffering stdout IO.NoBuffering - >> Env.getEnv "CODEROOT" - +> \root -> - Cli.getAllArgs args (Cli.argument "target") - |> filterM Dir.doesFileExist - +> filterM (\x -> isGitIgnored x /> don't) - /> filter (\x -> isGitHook x |> don't) - +> traverse Dir.makeAbsolute - +> traverse (namespaceFromPathOrDie root) - /> filter isBuildableNs - +> foldM analyze mempty - +> printOrBuild - |> Timeout.timeout (toMillis minutes) - +> \case - Nothing -> - Log.br - >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"] - >> Log.br - >> exitWith (ExitFailure 124) - Just s -> exitSummary s + root <- getCoderoot + loadGhcPkgCache + allNamespaces <- + Cli.getAllArgs args (Cli.argument "target") + |> filterM Dir.doesFileExist + +> filterGitIgnored + /> filter (\x -> isGitHook x |> don't) + +> traverse Dir.makeAbsolute + +> traverse (namespaceFromPathOrDie root) + let (namespaces, skippedNamespaces) = partition isBuildableNs allNamespaces + let isPlanMode = args `Cli.has` Cli.longOption "plan" + if isPlanMode + then do + analysis <- analyzeAll True namespaces + if Map.null analysis + then Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1) + else putJSON analysis + else do + when (null allNamespaces) <| do + Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1) + nproc <- GHC.getNumProcessors + createHier root + let runWithManager action = + if isLoud + then action + else + LogC.withLineManager allNamespaces <| \mgr -> do + LogC.initializeLines mgr + forM_ skippedNamespaces <| \ns -> LogC.updateLineState ns LogC.Skipped + action + runWithManager <| do + pipelineBuild isTest isLoud 8 jobs (cpus nproc) namespaces analyzeOne + |> Timeout.timeout (toMillis minutes) + +> \case + Nothing -> + Log.br + >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"] + >> Log.br + >> exitWith (ExitFailure 124) + Just s -> do + when (all isSuccess s) saveGhcPkgCache + exitSummary s where minutes = Cli.getArgWithDefault args "10" (Cli.longOption "time") @@ -226,20 +267,6 @@ move args = |> \case Nothing -> panic "could not read --time argument" Just n -> (n == 0) ?: (-1, n) - printOrBuild :: Analysis -> IO [ExitCode] - printOrBuild targets - | Map.null targets = - Log.wipe - >> Log.fail ["bild", "nothing to build"] - >> Log.br - >> exitWith (ExitFailure 1) - | args `Cli.has` Cli.longOption "plan" = - Log.wipe >> putJSON targets >> pure [Exit.ExitSuccess] - | otherwise = do - root <- Env.getEnv "CODEROOT" - nproc <- GHC.getNumProcessors - createHier root - build isTest isLoud jobs (cpus nproc) targets cpus :: Int -> Int cpus nproc = Cli.longOption "cpus" @@ -268,6 +295,20 @@ isGitIgnored path = (ExitSuccess, _, _) -> pure True (ExitFailure _, _, _) -> pure False +filterGitIgnored :: [FilePath] -> IO [FilePath] +filterGitIgnored [] = pure [] +filterGitIgnored paths = do + (exitCode, out, _) <- + Process.readProcessWithExitCode + "git" + ["check-ignore", "--stdin"] + (List.intercalate "\n" paths) + case exitCode of + ExitSuccess -> + let ignoredPaths = Set.fromList (String.lines out) + in pure [p | p <- paths, don't (Set.member p ignoredPaths)] + ExitFailure _ -> pure paths + test_isGitIgnored :: Test.Tree test_isGitIgnored = Test.group @@ -289,10 +330,10 @@ test_isGitHook = Test.group "isGitHook" [ Test.unit "filters pre-commit hook" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot True @=? (isGitHook <| root <> "/Omni/Ide/hooks/pre-commit"), Test.unit "doesn't filter non-hooks" <| do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot False @=? (isGitHook <| root <> "/Omni/Bild.hs") ] @@ -401,20 +442,37 @@ data Target = Target -- | Wrapper script (if necessary) wrapper :: Maybe Text, -- | Runtime dependences - rundeps :: Set Meta.Run + rundeps :: Set Meta.Run, + -- | Haskell module graph for per-module builds (Nothing means fallback to monolithic) + hsGraph :: Maybe HsModuleGraph + } + deriving (Show, Generic, Aeson.ToJSON) + +type ModuleName = Text + +data HsModuleNode = HsModuleNode + { nodePath :: FilePath, + nodeImports :: [ModuleName], + nodeHasTH :: Bool + } + deriving (Show, Generic, Aeson.ToJSON) + +data HsModuleGraph = HsModuleGraph + { graphEntry :: ModuleName, + graphModules :: Map ModuleName HsModuleNode } deriving (Show, Generic, Aeson.ToJSON) -- | Use this to just get a target to play with at the repl. dev_getTarget :: FilePath -> IO Target dev_getTarget fp = do - root <- Env.getEnv "CODEROOT" + root <- getCoderoot path <- Dir.makeAbsolute fp Namespace.fromPath root path |> \case Nothing -> panic "Could not get namespace from path" Just ns -> - analyze mempty ns + analyzeAll False [ns] /> Map.lookup ns /> \case Nothing -> panic "Could not retrieve target from analysis" @@ -456,7 +514,7 @@ isBuildableNs = \case (Namespace _ Namespace.Sh) -> False (Namespace _ Namespace.Scm) -> True (Namespace _ Namespace.Rs) -> True - (Namespace _ Namespace.Toml) -> True + (Namespace _ Namespace.Toml) -> False -- | The default output directory. This is not IO because I don't want to -- refactor all of my code right now, but it probably should be. @@ -502,100 +560,100 @@ removeVersion = takeWhile (/= '.') .> butlast2 type Analysis = Map Namespace Target -analyze :: Analysis -> Namespace -> IO Analysis -analyze hmap ns = case Map.lookup ns hmap of - Nothing -> do - mTarget <- analyzeOne ns - pure <| maybe hmap (\t -> Map.insert ns t hmap) mTarget - Just _ -> pure hmap - where - analyzeOne :: Namespace -> IO (Maybe Target) - analyzeOne namespace@(Namespace parts ext) = do - let path = Namespace.toPath namespace - root <- Env.getEnv "CODEROOT" - let abspath = root </> path - let quapath = path - user <- Env.getEnv "USER" /> Text.pack - host <- HostName.getHostName /> Text.pack - Log.info ["bild", "analyze", str path] - contentLines <- - withFile abspath ReadMode <| \h -> - IO.hSetEncoding h IO.utf8_bom - >> Text.IO.hGetContents h - /> Text.lines - -- if the file is exe but doesn't have 'out' metadata, just use the - -- dot-separated namespace instead - isExe <- Dir.getPermissions quapath /> Dir.executable - let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing) - case ext of - -- basically we don't support building these - Namespace.Css -> pure Nothing - Namespace.Json -> pure Nothing - Namespace.Keys -> pure Nothing - Namespace.Md -> pure Nothing - Namespace.None -> pure Nothing - Namespace.Html -> pure Nothing - Namespace.Toml -> pure Nothing - Namespace.Py -> - contentLines - |> Meta.detectAll "#" - |> \Meta.Parsed {..} -> - detectPythonImports contentLines +> \srcs -> - Target - { builder = "python", - wrapper = Nothing, - compiler = CPython, - compilerFlags = - -- This doesn't really make sense for python, but I'll leave - -- it here for eventual --dev builds - [ "-c", - "\"import py_compile;import os;" - <> "py_compile.compile(file='" - <> str quapath - <> "', cfile=os.getenv('CODEROOT')+'/_/int/" - <> str quapath - <> "', doraise=True)\"" - ], - sysdeps = psys, - langdeps = pdep, - outPath = outToPath pout, - out = pout <|> defaultOut, - packageSet = "python.packages", - mainModule = Namespace.toModule namespace, - rundeps = prun, - .. - } - |> Just - |> pure - Namespace.Sh -> pure Nothing - Namespace.C -> - Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do +analyzeAll :: Bool -> [Namespace] -> IO Analysis +analyzeAll _isPlanMode nss = do + targets <- mapConcurrentlyBounded 8 analyzeOne nss + pure <| Map.fromList <| catMaybes <| zipWith (\ns mt -> (ns,) </ mt) nss targets + +analyzeOne :: Namespace -> IO (Maybe Target) +analyzeOne namespace@(Namespace parts ext) = do + let path = Namespace.toPath namespace + root <- getCoderoot + let abspath = root </> path + let quapath = path + user <- Env.getEnv "USER" /> Text.pack + host <- HostName.getHostName /> Text.pack + contentLines <- + withFile abspath ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + isExe <- Dir.getPermissions quapath /> Dir.executable + let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing) + case ext of + Namespace.Css -> pure Nothing + Namespace.Json -> pure Nothing + Namespace.Keys -> pure Nothing + Namespace.Md -> pure Nothing + Namespace.None -> pure Nothing + Namespace.Html -> pure Nothing + Namespace.Toml -> pure Nothing + Namespace.Py -> + contentLines + |> Meta.detectAll "#" + |> \Meta.Parsed {..} -> + detectPythonImports mempty contentLines +> \(srcs, transitiveDeps) -> Target - { langdeps = pdep, - sysdeps = psys, + { builder = "python", wrapper = Nothing, - compiler = Gcc, - builder = "c", + compiler = CPython, + compilerFlags = + -- This doesn't really make sense for python, but I'll leave + -- it here for eventual --dev builds + [ "-c", + "\"import py_compile;import os;" + <> "py_compile.compile(file='" + <> str quapath + <> "', cfile=os.getenv('CODEROOT')+'/_/int/" + <> str quapath + <> "', doraise=True)\"" + ], + sysdeps = psys, + langdeps = pdep <> transitiveDeps, + outPath = outToPath pout, out = pout <|> defaultOut, - packageSet = "c.packages", + packageSet = "python.packages", mainModule = Namespace.toModule namespace, - compilerFlags = case pout of - Just o -> - ["-o", o, path] <> Set.toList parg |> map Text.pack - Nothing -> panic "can only bild C exes, not libs", - outPath = outToPath pout, - -- implement detectCImports, then I can fill this out - srcs = Set.empty, rundeps = prun, + hsGraph = Nothing, .. } |> Just |> pure - Namespace.Hs -> - contentLines - |> Meta.detectAll "--" - |> \Meta.Parsed {..} -> - detectHaskellImports hmap contentLines +> \(langdeps, srcs) -> + Namespace.Sh -> pure Nothing + Namespace.C -> + Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do + Target + { langdeps = pdep, + sysdeps = psys, + wrapper = Nothing, + compiler = Gcc, + builder = "c", + out = pout <|> defaultOut, + packageSet = "c.packages", + mainModule = Namespace.toModule namespace, + compilerFlags = case pout of + Just o -> + ["-o", o, path] <> Set.toList parg |> map Text.pack + Nothing -> panic "can only bild C exes, not libs", + outPath = outToPath pout, + -- implement detectCImports, then I can fill this out + srcs = Set.empty, + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Hs -> + contentLines + |> Meta.detectAll "--" + |> \Meta.Parsed {..} -> + detectHaskellImports mempty contentLines +> \(autoDeps, srcs) -> do + let langdeps = autoDeps <> pdep + graph <- buildHsModuleGraph namespace quapath srcs + pure + <| Just Target { builder = "haskell", wrapper = Nothing, @@ -629,182 +687,181 @@ analyze hmap ns = case Map.lookup ns hmap of outPath = outToPath pout, rundeps = prun, out = pout <|> defaultOut, + hsGraph = graph, .. } - |> Just - |> pure - Namespace.Lisp -> - Meta.detectOut (Meta.out ";;") contentLines |> \out -> do - langdeps <- detectLispImports contentLines - Just - </ pure - Target - { sysdeps = Set.empty, - wrapper = Nothing, - compiler = Sbcl, - packageSet = "lisp.sbclWith", - mainModule = Namespace.toModule namespace, - compilerFlags = - map - Text.pack - [ "--eval", - "(require :asdf)", - "--load", - quapath, - "--eval", - "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)" - ], - builder = "base", - outPath = outToPath out, - -- add local src imports to detectLispImports, then i can fill this out - srcs = Set.empty, - rundeps = Set.empty, - .. - } - Namespace.Nix -> - (host == "lithium") ?: (Local user "lithium", Remote user "dev.bensima.com") |> \builder -> + Namespace.Lisp -> + Meta.detectOut (Meta.out ";;") contentLines |> \out -> do + langdeps <- detectLispImports contentLines + Just + </ pure Target - { langdeps = Set.empty, + { sysdeps = Set.empty, wrapper = Nothing, - sysdeps = Set.empty, - compiler = NixBuild, - compilerFlags = - [ quapath, - "--out-link", - root </> nixdir </> Namespace.toPath namespace, - "--builders", - toNixFlag builder, - "--arg", - "bild", - str <| "import " <> root </> "Omni/Bild.nix {}" - ] - |> map Text.pack, - out = Nothing, - outPath = outToPath Nothing, - srcs = Set.empty, - packageSet = "", - mainModule = Namespace.toModule namespace, - builder = "base", - rundeps = Set.empty, - .. - } - |> Just - |> pure - Namespace.Scm -> - Meta.detectAll ";;" contentLines |> \Meta.Parsed {..} -> - Target - { langdeps = pdep, - sysdeps = psys, - compiler = Guile, - packageSet = "scheme.guilePackages", + compiler = Sbcl, + packageSet = "lisp.sbclWith", mainModule = Namespace.toModule namespace, compilerFlags = - [ "compile", - "--r7rs", - "--load-path=" ++ root, - "--output=" ++ root </> intdir </> replaceExtension quapath ".scm.go", - quapath - ] - |> map Text.pack, - builder = "base", - outPath = outToPath pout, - out = pout <|> defaultOut, - srcs = Set.empty, -- implement detectSchemeImports - -- TODO: wrapper should just be removed, instead rely on - -- upstream nixpkgs builders to make wrappers - wrapper = - isNothing pout - ?: ( Nothing, - [ "#!/usr/bin/env bash", - "guile -C \"" - <> root - </> intdir - <> "\" -e main " - <> "-s " - <> Namespace.toPath namespace - <> " \"$@\"" - ] - |> joinWith "\n" - |> Text.pack - |> Just - ), - rundeps = prun, - .. - } - |> Just - |> pure - Namespace.Rs -> - Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> - Target - { langdeps = pdep, - -- this packageSet doesn't actually exist because everyone in - -- nix just generates nix expressions for rust dependencies with - -- Cargo.lock, so I have to make it in order to use rust deps - packageSet = "rust.packages", - mainModule = Namespace.toModule namespace, - wrapper = Nothing, - sysdeps = psys <> Set.singleton "rustc", - out = pout <|> defaultOut, - compiler = Rustc, - compilerFlags = case pout of - Just o -> - map - Text.pack - [ "$CODEROOT" </> path, - "-o", - o - ] - Nothing -> panic "can't build rust libs", + map + Text.pack + [ "--eval", + "(require :asdf)", + "--load", + quapath, + "--eval", + "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)" + ], builder = "base", - outPath = outToPath pout, - -- implement detectRustImports + outPath = outToPath out, + -- add local src imports to detectLispImports, then i can fill this out srcs = Set.empty, - rundeps = prun, + rundeps = Set.empty, + hsGraph = Nothing, .. } - |> Just - |> pure + Namespace.Nix -> + (host == "lithium") ?: (Local user "lithium", Remote user "dev.bensima.com") |> \builder -> + Target + { langdeps = Set.empty, + wrapper = Nothing, + sysdeps = Set.empty, + compiler = NixBuild, + compilerFlags = + [ quapath, + "--out-link", + root </> nixdir </> Namespace.toPath namespace, + "--builders", + toNixFlag builder, + "--arg", + "bild", + str <| "import " <> root </> "Omni/Bild.nix {}" + ] + |> map Text.pack, + out = Nothing, + outPath = outToPath Nothing, + srcs = Set.empty, + packageSet = "", + mainModule = Namespace.toModule namespace, + builder = "base", + rundeps = Set.empty, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Scm -> + Meta.detectAll ";;" contentLines |> \Meta.Parsed {..} -> + Target + { langdeps = pdep, + sysdeps = psys, + compiler = Guile, + packageSet = "scheme.guilePackages", + mainModule = Namespace.toModule namespace, + compilerFlags = + [ "compile", + "--r7rs", + "--load-path=" ++ root, + "--output=" ++ root </> intdir </> replaceExtension quapath ".scm.go", + quapath + ] + |> map Text.pack, + builder = "base", + outPath = outToPath pout, + out = pout <|> defaultOut, + srcs = Set.empty, -- implement detectSchemeImports + -- TODO: wrapper should just be removed, instead rely on + -- upstream nixpkgs builders to make wrappers + wrapper = + isNothing pout + ?: ( Nothing, + [ "#!/usr/bin/env bash", + "guile -C \"" + <> root + </> intdir + <> "\" -e main " + <> "-s " + <> Namespace.toPath namespace + <> " \"$@\"" + ] + |> joinWith "\n" + |> Text.pack + |> Just + ), + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure + Namespace.Rs -> + Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> + Target + { langdeps = pdep, + -- this packageSet doesn't actually exist because everyone in + -- nix just generates nix expressions for rust dependencies with + -- Cargo.lock, so I have to make it in order to use rust deps + packageSet = "rust.packages", + mainModule = Namespace.toModule namespace, + wrapper = Nothing, + sysdeps = psys <> Set.singleton "rustc", + out = pout <|> defaultOut, + compiler = Rustc, + compilerFlags = case pout of + Just o -> + map + Text.pack + [ "$CODEROOT" </> path, + "-o", + o + ] + Nothing -> panic "can't build rust libs", + builder = "base", + outPath = outToPath pout, + -- implement detectRustImports + srcs = Set.empty, + rundeps = prun, + hsGraph = Nothing, + .. + } + |> Just + |> pure detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath) -detectHaskellImports hmap contentLines = - Env.getEnv "CODEROOT" +> \root -> - contentLines - /> Text.unpack - /> Regex.match haskellImports - |> catMaybes - |> \imports -> - foldM ghcPkgFindModule Set.empty imports - +> \pkgs -> - filepaths imports - +> \files -> - findDeps root files - +> \deps -> - (pkgs <> deps, map (stripRoot root) files |> Set.fromList) - |> pure +detectHaskellImports _ contentLines = do + root <- getCoderoot + let initialMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ contentLines)) + initialLocals <- toLocalFiles root initialMods + let initialLocalsSet = Set.fromList initialLocals + let localMods = [m | m <- initialMods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` initialLocals] + let initialExternals = filter (`notElem` localMods) initialMods + (srcs, transitiveExtMods) <- bfs root initialLocalsSet Set.empty Set.empty + let allExtMods = Set.fromList initialExternals <> transitiveExtMods + pkgSets <- Async.mapConcurrently ghcPkgFindModuleCached (Set.toList allExtMods) + let pkgs = mconcat pkgSets + pure (pkgs, srcs) where - filepaths :: [String] -> IO [FilePath] - filepaths imports = - imports - |> map Namespace.fromHaskellModule - |> map Namespace.toPath - |> traverse Dir.makeAbsolute - +> filterM Dir.doesFileExist - findDeps :: String -> [FilePath] -> IO (Set Meta.Dep) - findDeps root fps = - fps - |> traverse (pure <. Namespace.fromPath root) - /> catMaybes - -- this is still an inefficiency, because this recurses before the - -- hmap is updated by the fold, transitive imports will be - -- re-visited. you can see this with `TERM=dumb bild`. to fix this i - -- need shared state instead of a fold, or figure out how to do a - -- breadth-first search instead of depth-first. - +> foldM analyze (onlyHaskell hmap) - /> Map.elems - /> map langdeps - /> mconcat - onlyHaskell :: Analysis -> Analysis - onlyHaskell = Map.filterWithKey (\ns _ -> ext ns == Namespace.Hs) + bfs :: FilePath -> Set FilePath -> Set FilePath -> Set String -> IO (Set FilePath, Set String) + bfs root queue visited extMods + | Set.null queue = pure (visited, extMods) + | otherwise = do + let (rel, queue') = Set.deleteFindMin queue + fileLines <- + withFile (root </> rel) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let mods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines)) + locals <- toLocalFiles root mods + let localsSet = Set.fromList locals + let localModsFromPaths = Set.fromList [m | m <- mods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` locals] + let newExternals = Set.fromList mods Set.\\ localModsFromPaths + let newLocals = localsSet Set.\\ visited + bfs root (queue' <> newLocals) (Set.insert rel visited) (extMods <> newExternals) + + toLocalFiles :: FilePath -> [String] -> IO [FilePath] + toLocalFiles root mods = do + let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels stripRoot :: FilePath -> FilePath -> FilePath stripRoot root f = fromMaybe f (List.stripPrefix (root <> "/") f) @@ -818,19 +875,14 @@ detectLispImports contentLines = |> Set.fromList |> pure --- | Finds local imports. Does not recurse to find transitive imports like --- 'detectHaskellImports' does. Someday I will refactor these detection --- functions and have a common, well-performing, complete solution. -detectPythonImports :: [Text] -> IO (Set FilePath) -detectPythonImports contentLines = - contentLines - /> Text.unpack - /> Regex.match pythonImport - |> catMaybes - /> Namespace.fromPythonModule - /> Namespace.toPath - |> filterM Dir.doesPathExist - /> Set.fromList +-- | Finds local imports and recursively finds transitive imports and langdeps. +-- Returns (srcs, transitive langdeps). +detectPythonImports :: Analysis -> [Text] -> IO (Set FilePath, Set Meta.Dep) +detectPythonImports _ contentLines = do + root <- getCoderoot + let initialMods = catMaybes (Regex.match pythonImport </ (Text.unpack </ contentLines)) + initialLocals <- toLocalFiles root initialMods + bfs root (Set.fromList initialLocals) Set.empty Set.empty where -- only detects 'import x' because I don't like 'from' pythonImport :: Regex.RE Char String @@ -840,18 +892,138 @@ detectPythonImports contentLines = *> Regex.many (Regex.psym isModuleChar) <* Regex.many Regex.anySym + bfs :: FilePath -> Set FilePath -> Set FilePath -> Set Meta.Dep -> IO (Set FilePath, Set Meta.Dep) + bfs root queue visited deps + | Set.null queue = pure (visited, deps) + | otherwise = do + let (rel, queue') = Set.deleteFindMin queue + fileLines <- + withFile (root </> rel) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let mods = catMaybes (Regex.match pythonImport </ (Text.unpack </ fileLines)) + locals <- toLocalFiles root mods + let localsSet = Set.fromList locals + let newLocals = localsSet Set.\\ visited + -- Collect langdeps from this file's metadata + let Meta.Parsed {pdep = fileDeps} = Meta.detectAll "#" fileLines + bfs root (queue' <> newLocals) (Set.insert rel visited) (deps <> fileDeps) + + toLocalFiles :: FilePath -> [String] -> IO [FilePath] + toLocalFiles root mods = do + let rels = map (Namespace.fromPythonModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels + test_detectPythonImports :: Test.Tree test_detectPythonImports = Test.group "detectPythonImports" [ Test.unit "matches import statements" <| do - set <- detectPythonImports ["import Omni.Log"] - Set.fromList ["Omni/Log.py"] @=? set, + (srcs, _) <- detectPythonImports mempty ["import Omni.Log"] + Set.fromList ["Omni/Log.py"] @=? srcs, Test.unit "matches import as statements" <| do - set <- detectPythonImports ["import Omni.Log as Log"] - Set.fromList ["Omni/Log.py"] @=? set + (srcs, _) <- detectPythonImports mempty ["import Omni.Log as Log"] + Set.fromList ["Omni/Log.py"] @=? srcs + ] + +test_buildHsModuleGraph :: Test.Tree +test_buildHsModuleGraph = + Test.group + "buildHsModuleGraph" + [ Test.unit "includes entry point in graph" <| do + let ns = Namespace ["Omni", "Bild", "Example"] Namespace.Hs + let entryPoint = "Omni/Bild/Example.hs" + let deps = Set.fromList ["Alpha.hs", "Omni/Test.hs"] + + result <- buildHsModuleGraph ns entryPoint deps + case result of + Nothing -> Test.assertFailure "buildHsModuleGraph returned Nothing" + Just graph -> do + let modules = Map.keys (graphModules graph) + Text.pack "Omni.Bild.Example" `elem` modules @=? True ] +type GhcPkgCacheMem = Map String (Set String) + +type GhcPkgCacheDisk = Map String [String] + +{-# NOINLINE ghcPkgCache #-} +ghcPkgCache :: IORef GhcPkgCacheMem +ghcPkgCache = unsafePerformIO (newIORef Map.empty) + +cacheToDisk :: GhcPkgCacheMem -> GhcPkgCacheDisk +cacheToDisk = Map.map Set.toList + +cacheFromDisk :: GhcPkgCacheDisk -> GhcPkgCacheMem +cacheFromDisk = Map.map Set.fromList + +ghcPkgCacheHash :: IO (Maybe String) +ghcPkgCacheHash = do + mdb <- Env.lookupEnv "GHC_PACKAGE_PATH" + case mdb of + Nothing -> pure Nothing + Just db -> do + v <- + Exception.catch + ( Process.readProcess "ghc" ["--numeric-version"] "" + /> takeWhile (/= '\n') + ) + (\(_ :: Exception.SomeException) -> pure "") + if null v then pure Nothing else pure (Just (hashString (v <> "|" <> db))) + where + hashString :: String -> String + hashString s = + List.foldl' (\h c -> h * 131 + fromEnum c) (7 :: Int) s + |> abs + |> toInteger + |> \n -> Numeric.showHex n "" + +ghcPkgCachePath :: IO (Maybe FilePath) +ghcPkgCachePath = do + root <- getCoderoot + fmap (\h -> root </> vardir </> ("ghc-pkg-cache-" <> h <> ".json")) </ ghcPkgCacheHash + +loadGhcPkgCache :: IO () +loadGhcPkgCache = do + mpath <- ghcPkgCachePath + case mpath of + Nothing -> pure () + Just path -> do + exists <- Dir.doesFileExist path + if not exists + then pure () + else do + eres <- Exception.try (ByteString.Lazy.readFile path) :: IO (Either Exception.IOException ByteString.Lazy.ByteString) + case eres of + Left _ -> pure () + Right bs -> + case Aeson.eitherDecode bs :: Either String GhcPkgCacheDisk of + Left _ -> pure () + Right disk -> writeIORef ghcPkgCache (cacheFromDisk disk) + +saveGhcPkgCache :: IO () +saveGhcPkgCache = do + mpath <- ghcPkgCachePath + case mpath of + Nothing -> pure () + Just path -> do + cache <- readIORef ghcPkgCache + let tmp = path <> ".tmp" + Dir.createDirectoryIfMissing True (takeDirectory path) + ByteString.Lazy.writeFile tmp (Aeson.encode (cacheToDisk cache)) + Dir.renameFile tmp path + +ghcPkgFindModuleCached :: String -> IO (Set String) +ghcPkgFindModuleCached m = do + cache <- readIORef ghcPkgCache + case Map.lookup m cache of + Just pkgs -> pure pkgs + Nothing -> do + pkgs <- ghcPkgFindModule Set.empty m + modifyIORef' ghcPkgCache (Map.insert m pkgs) + pure pkgs + ghcPkgFindModule :: Set String -> String -> IO (Set String) ghcPkgFindModule acc m = Env.getEnv "GHC_PACKAGE_PATH" +> \packageDb -> @@ -863,6 +1035,81 @@ ghcPkgFindModule acc m = /> Set.fromList /> Set.union acc +-- | Build module graph for Haskell targets, returns Nothing if TH or cycles detected +buildHsModuleGraph :: Namespace -> FilePath -> Set FilePath -> IO (Maybe HsModuleGraph) +buildHsModuleGraph namespace entryPoint deps = do + root <- getCoderoot + -- Analyze all dependencies first + depNodes <- foldM (analyzeModule root) Map.empty (Set.toList deps) + -- Then analyze the entry point itself + allNodes <- analyzeModule root depNodes entryPoint + let hasTH = any nodeHasTH (Map.elems allNodes) + let hasCycles = detectCycles allNodes + if hasTH || hasCycles + then pure Nothing + else + pure + <| Just + HsModuleGraph + { graphEntry = Namespace.toHaskellModule namespace |> Text.pack, + graphModules = allNodes + } + where + analyzeModule :: FilePath -> Map ModuleName HsModuleNode -> FilePath -> IO (Map ModuleName HsModuleNode) + analyzeModule root acc srcPath = do + let modName = pathToModuleName srcPath + case Map.lookup modName acc of + Just _ -> pure acc + Nothing -> do + fileLines <- + withFile (root </> srcPath) ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + /> Text.lines + let importedMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines)) + localImportMods <- filterLocalImports root importedMods + let hasTH = detectTH fileLines + let node = + HsModuleNode + { nodePath = srcPath, + nodeImports = map Text.pack localImportMods, + nodeHasTH = hasTH + } + pure (Map.insert modName node acc) + + pathToModuleName :: FilePath -> ModuleName + pathToModuleName fp = + fp + |> dropExtension + |> map (\c -> if c == '/' then '.' else c) + |> Text.pack + + filterLocalImports :: FilePath -> [String] -> IO [String] + filterLocalImports root mods = do + let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods + filterM (\rel -> Dir.doesFileExist (root </> rel)) rels + /> map (\rel -> replaceExtension rel "" |> map (\c -> if c == '/' then '.' else c)) + + detectTH :: [Text] -> Bool + detectTH = + any + ( \line -> + Text.isInfixOf "TemplateHaskell" line + || Text.isInfixOf "$(" line + ) + + detectCycles :: Map ModuleName HsModuleNode -> Bool + detectCycles nodes = + let sccs = stronglyConnComp (map nodeToEdge (Map.toList nodes)) + in any isNonTrivialSCC sccs + where + nodeToEdge :: (ModuleName, HsModuleNode) -> (HsModuleNode, ModuleName, [ModuleName]) + nodeToEdge (name, node) = (node, name, nodeImports node) + + isNonTrivialSCC :: SCC HsModuleNode -> Bool + isNonTrivialSCC (AcyclicSCC _) = False + isNonTrivialSCC (CyclicSCC sccNodes) = length sccNodes > 1 + isFailure :: Exit.ExitCode -> Bool isFailure (Exit.ExitFailure _) = True isFailure Exit.ExitSuccess = False @@ -873,7 +1120,7 @@ isSuccess _ = False test :: Bool -> Target -> IO (Exit.ExitCode, ByteString) test loud Target {..} = - Env.getEnv "CODEROOT" + getCoderoot +> \root -> case compiler of Ghc -> Proc @@ -881,8 +1128,8 @@ test loud Target {..} = cmd = root </> outToPath out, args = ["test"], ns = namespace, - onFailure = Log.fail ["test", nschunk namespace] >> Log.br, - onSuccess = Log.pass ["test", nschunk namespace] >> Log.br + onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) } |> run CPython -> @@ -891,41 +1138,42 @@ test loud Target {..} = cmd = root </> outToPath out, args = ["test"], ns = namespace, - onFailure = Log.fail ["test", nschunk namespace] >> Log.br, - onSuccess = Log.pass ["test", nschunk namespace] >> Log.br + onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed), + onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success) } |> run _ -> - Log.warn ["test", nschunk namespace, "unavailable"] - >> Log.br - >> pure (Exit.ExitFailure 1, mempty) + pure (Exit.ExitFailure 1, mempty) build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode] -build andTest loud jobs cpus analysis = - Env.getEnv "CODEROOT" +> \root -> - forM (Map.elems analysis) <| \target@Target {..} -> - fst </ case compiler of +build andTest loud jobs cpus analysis = do + root <- getCoderoot + let targets = Map.elems analysis + -- Build runs concurrently with --jobs parallelism + -- LineManager is set up by caller (move), so we just update states here + results <- mapConcurrentlyBounded jobs (buildTarget root) targets + pure (map fst results) + where + buildTarget :: FilePath -> Target -> IO (Exit.ExitCode, ByteString) + buildTarget root target@Target {..} = do + LogC.updateLineState namespace LogC.Building + result <- case compiler of CPython -> case out of Just _ -> - Log.info ["bild", "nix", "python", nschunk namespace] - >> nixBuild loud jobs cpus target + nixBuild loud jobs cpus target +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r)) Nothing -> - Log.info ["bild", "nix", "python", nschunk namespace, "cannot build library"] - >> pure (Exit.ExitSuccess, mempty) + pure (Exit.ExitSuccess, mempty) Gcc -> - Log.info ["bild", "nix", "gcc", nschunk namespace] - >> nixBuild loud jobs cpus target + nixBuild loud jobs cpus target Ghc -> case out of Nothing -> pure (Exit.ExitSuccess, mempty) Just _ -> do - Log.info ["bild", "nix", user <> "@" <> host, nschunk namespace] result <- nixBuild loud jobs cpus target if andTest && (isSuccess <| fst result) then test loud target else pure result Guile -> do - Log.info ["bild", "dev", "guile", nschunk namespace] _ <- proc loud namespace (toNixFlag compiler) compilerFlags case wrapper of Nothing -> pure (Exit.ExitSuccess, mempty) @@ -937,30 +1185,232 @@ build andTest loud jobs cpus analysis = NixBuild -> Dir.getPermissions quapath /> Dir.executable +> \isExe -> isExe - ?: ( Log.info ["bild", "nix", user <> "@" <> host, nschunk namespace] - >> proc - loud - namespace - (toNixFlag compiler) - ( compilerFlags - ++ [ "--max-jobs", - Text.pack <| str jobs, - "--cores", - Text.pack <| str cpus - ] - ), - Log.warn ["bild", "nix", nschunk namespace, "x bit not set, not building"] - >> pure (Exit.ExitSuccess, mempty) + ?: ( proc + loud + namespace + (toNixFlag compiler) + ( compilerFlags + ++ [ "--max-jobs", + Text.pack <| str jobs, + "--cores", + Text.pack <| str cpus + ] + ), + pure (Exit.ExitSuccess, mempty) ) - Copy -> do - Log.warn ["bild", "copy", "not implemented yet", nschunk namespace] + Copy -> pure (Exit.ExitSuccess, mempty) Rustc -> - Log.info ["bild", "dev", "rust", nschunk namespace] - >> nixBuild loud jobs cpus target - Sbcl -> do - Log.info ["bild", "dev", "lisp", nschunk namespace] + nixBuild loud jobs cpus target + Sbcl -> proc loud namespace (toNixFlag compiler) compilerFlags + LogC.updateLineState namespace (isSuccess (fst result) ?: (LogC.Success, LogC.Failed)) + pure result + +-- | Pipeline state machine for each target +data TargetState + = TSQueued + | TSAnalyzing + | TSAnalysisFailed + | TSWaitingForDeps Target (Set Namespace) + | TSReadyToBuild Target + | TSBuilding Target + | TSComplete Target Exit.ExitCode + +-- | Coordinator manages the pipelined analyze→build flow +data Coordinator = Coordinator + { coStates :: TVar (Map Namespace TargetState), + coAnalyzeQ :: TQueue Namespace, + coBuildQ :: TQueue Namespace, + coAllTargets :: Set Namespace, + coResults :: TVar [Exit.ExitCode], + coRemaining :: TVar Int, + coRoot :: FilePath + } + +initCoordinator :: FilePath -> [Namespace] -> IO Coordinator +initCoordinator root nss = + atomically <| do + let allTargets = Set.fromList nss + states <- newTVar (Map.fromList [(ns, TSQueued) | ns <- nss]) + analyzeQ <- newTQueue + buildQ <- newTQueue + results <- newTVar [] + remaining <- newTVar (length nss) + forM_ nss (writeTQueue analyzeQ) + pure + Coordinator + { coStates = states, + coAnalyzeQ = analyzeQ, + coBuildQ = buildQ, + coAllTargets = allTargets, + coResults = results, + coRemaining = remaining, + coRoot = root + } + +computeDeps :: Coordinator -> Target -> Set Namespace +computeDeps Coordinator {..} Target {..} = + let toNs path = Namespace.fromPath coRoot (coRoot </> path) + result = + srcs + |> Set.toList + |> map toNs + |> catMaybes + |> Set.fromList + |> flip Set.intersection coAllTargets + |> Set.delete namespace + in result + +tsIsComplete :: TargetState -> Bool +tsIsComplete (TSComplete _ _) = True +tsIsComplete _ = False + +pipelineAnalysisWorker :: Coordinator -> (Namespace -> IO (Maybe Target)) -> IO () +pipelineAnalysisWorker coord@Coordinator {..} analyzeFn = loop + where + loop = do + remaining <- readTVarIO coRemaining + when (remaining > 0) <| do + mNs <- atomically (tryReadTQueue coAnalyzeQ) + case mNs of + Nothing -> threadDelay 1000 >> loop + Just ns -> do + atomically <| modifyTVar' coStates (Map.insert ns TSAnalyzing) + LogC.updateLineState ns LogC.Analyzing + result <- analyzeFn ns + case result of + Nothing -> do + atomically <| do + modifyTVar' coStates (Map.insert ns TSAnalysisFailed) + modifyTVar' coRemaining (subtract 1) + LogC.updateLineState ns LogC.Failed + Just target -> do + let deps = computeDeps coord target + atomically <| do + states <- readTVar coStates + let pendingDeps = Set.filter (\d -> maybe True (tsIsComplete .> not) (Map.lookup d states)) deps + if Set.null pendingDeps + then do + modifyTVar' coStates (Map.insert ns (TSReadyToBuild target)) + writeTQueue coBuildQ ns + else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target pendingDeps)) + loop + +pipelineBuildWorker :: Bool -> Bool -> Int -> Int -> Coordinator -> IO () +pipelineBuildWorker andTest loud jobs cpus coord@Coordinator {..} = loop + where + loop = do + remaining <- readTVarIO coRemaining + when (remaining > 0) <| do + mNs <- atomically (tryReadTQueue coBuildQ) + case mNs of + Nothing -> threadDelay 1000 >> loop + Just ns -> do + mTarget <- + atomically <| do + states <- readTVar coStates + case Map.lookup ns states of + Just (TSReadyToBuild t) -> do + modifyTVar' coStates (Map.insert ns (TSBuilding t)) + pure (Just t) + _ -> pure Nothing + case mTarget of + Nothing -> loop + Just target -> do + LogC.updateLineState ns LogC.Building + exitCode <- pipelineBuildOne andTest loud jobs cpus target + atomically <| do + modifyTVar' coStates (Map.insert ns (TSComplete target exitCode)) + modifyTVar' coResults (exitCode :) + modifyTVar' coRemaining (subtract 1) + promoteWaiters coord ns + LogC.updateLineState ns (isSuccess exitCode ?: (LogC.Success, LogC.Failed)) + loop + +promoteWaiters :: Coordinator -> Namespace -> STM () +promoteWaiters Coordinator {..} completedNs = do + states <- readTVar coStates + forM_ (Map.toList states) <| \(ns, st) -> + case st of + TSWaitingForDeps target deps -> do + let deps' = Set.delete completedNs deps + if Set.null deps' + then do + modifyTVar' coStates (Map.insert ns (TSReadyToBuild target)) + writeTQueue coBuildQ ns + else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target deps')) + _ -> pure () + +pipelineBuildOne :: Bool -> Bool -> Int -> Int -> Target -> IO Exit.ExitCode +pipelineBuildOne andTest loud jobs cpus target@Target {..} = do + root <- getCoderoot + result <- case compiler of + CPython -> case out of + Just _ -> + nixBuild loud jobs cpus target + +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r)) + Nothing -> + pure (Exit.ExitSuccess, mempty) + Gcc -> + nixBuild loud jobs cpus target + Ghc -> case out of + Nothing -> pure (Exit.ExitSuccess, mempty) + Just _ -> do + r <- nixBuild loud jobs cpus target + if andTest && (isSuccess <| fst r) + then test loud target + else pure r + Guile -> do + _ <- proc loud namespace (toNixFlag compiler) compilerFlags + case wrapper of + Nothing -> pure (Exit.ExitSuccess, mempty) + Just content -> do + writeFile (root </> outToPath out) content + p <- Dir.getPermissions <| root </> outToPath out + Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p) + pure (Exit.ExitSuccess, mempty) + NixBuild -> + Dir.getPermissions quapath /> Dir.executable +> \isExe -> + isExe + ?: ( proc + loud + namespace + (toNixFlag compiler) + ( compilerFlags + ++ [ "--max-jobs", + Text.pack <| str jobs, + "--cores", + Text.pack <| str cpus + ] + ), + pure (Exit.ExitSuccess, mempty) + ) + Copy -> + pure (Exit.ExitSuccess, mempty) + Rustc -> + nixBuild loud jobs cpus target + Sbcl -> + proc loud namespace (toNixFlag compiler) compilerFlags + pure (fst result) + +pipelineBuild :: Bool -> Bool -> Int -> Int -> Int -> [Namespace] -> (Namespace -> IO (Maybe Target)) -> IO [Exit.ExitCode] +pipelineBuild andTest loud analysisWorkers buildWorkers cpus namespaces analyzeFn = do + root <- getCoderoot + coord <- initCoordinator root namespaces + let spawnAnalysis = replicateM analysisWorkers (Async.async (pipelineAnalysisWorker coord analyzeFn)) + let spawnBuild = replicateM buildWorkers (Async.async (pipelineBuildWorker andTest loud buildWorkers cpus coord)) + threads <- (<>) </ spawnAnalysis <*> spawnBuild + let waitLoop = do + remaining <- readTVarIO (coRemaining coord) + if remaining == 0 + then pure () + else do + threadDelay 10000 + waitLoop + waitLoop + traverse_ Async.cancel threads + readTVarIO (coResults coord) data Proc = Proc { loud :: Bool, @@ -983,7 +1433,8 @@ run Proc {..} = do Conduit.proc cmd args |> (\proc_ -> proc_ {Process.create_group = True}) |> Conduit.streamingProcess - +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> + +> \(stdin_, stdout_, stderr_, hdl) -> do + IO.hClose stdin_ -- Close stdin immediately since we don't use it (,,) </ Async.Concurrently (Conduit.waitForStreamingProcess hdl) <*> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) @@ -1014,7 +1465,7 @@ proc loud namespace cmd args = cmd = cmd, args = map Text.unpack args, onFailure = Log.fail ["bild", nschunk namespace] >> Log.br, - onSuccess = Log.good ["bild", nschunk namespace] >> Log.br + onSuccess = pure () } |> run @@ -1041,10 +1492,11 @@ logs ns src = src .| Conduit.iterM ( ByteString.filter (/= BSI.c2w '\n') - .> (\t -> Log.fmt ["info", "bild", nschunk ns, decodeUtf8 t]) + .> decodeUtf8 .> Text.take (columns - 1) - .> (<> "…\r") - .> putStr + .> (<> "...") + .> LogC.updateLine ns + .> liftIO ) .| Conduit.foldC |> Conduit.runConduitRes @@ -1082,7 +1534,7 @@ lispRequires = nixBuild :: Bool -> Int -> Int -> Target -> IO (Exit.ExitCode, ByteString) nixBuild loud maxJobs cores target@(Target {..}) = - Env.getEnv "CODEROOT" +> \root -> + getCoderoot +> \root -> instantiate root |> run +> \case (_, "") -> panic "instantiate did not produce a drv" (Exit.ExitSuccess, drv) -> @@ -1092,7 +1544,9 @@ nixBuild loud maxJobs cores target@(Target {..}) = |> str |> realise |> run - >> run symlink + +> \case + (Exit.ExitSuccess, _) -> run symlink + failure -> pure failure x -> pure x where instantiate root = @@ -1129,7 +1583,7 @@ nixBuild loud maxJobs cores target@(Target {..}) = str cores ], onFailure = Log.fail ["bild", "realise", nschunk namespace] >> Log.br, - onSuccess = Log.good ["bild", nschunk namespace] >> Log.br + onSuccess = pure () } symlink = Proc @@ -1146,3 +1600,41 @@ nixBuild loud maxJobs cores target@(Target {..}) = onFailure = Log.fail ["bild", "symlink", nschunk namespace] >> Log.br, onSuccess = pure () } + +getCoderoot :: IO FilePath +getCoderoot = do + mEnvRoot <- Env.lookupEnv "CODEROOT" + cwd <- Dir.getCurrentDirectory + case mEnvRoot of + Just envRoot -> do + let isPrefix = envRoot `List.isPrefixOf` cwd + let validPrefix = + isPrefix + && ( length envRoot + == length cwd + || (length cwd > length envRoot && (List.!!) cwd (length envRoot) == '/') + ) + if validPrefix + then pure envRoot + else do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> pure envRoot + Nothing -> do + mRealRoot <- findRoot cwd + case mRealRoot of + Just realRoot -> pure realRoot + Nothing -> panic "CODEROOT not set and could not find root" + +findRoot :: FilePath -> IO (Maybe FilePath) +findRoot dir = do + let marker = dir </> "Omni" + exists <- Dir.doesDirectoryExist marker + if exists + then pure (Just dir) + else do + let parent = takeDirectory dir + if parent == dir + then pure Nothing + else findRoot parent |