diff options
| author | Ben Sima <ben@bsima.me> | 2025-11-14 17:01:21 -0500 |
|---|---|---|
| committer | Ben Sima <ben@bsima.me> | 2025-11-14 17:01:21 -0500 |
| commit | bffdc005275bf74cde864dabcfafec497dcf0013 (patch) | |
| tree | c4ac67eccb22d23458959d2643c07eb3981d204f /Omni/Bild.hs | |
| parent | bf608be61e97bab08e3f26f249762e63630549b4 (diff) | |
Implement concurrent analysis with [+] state indicator
- Add Analyzing state to BuildState enum - Refactor from sequential
foldM analyze to concurrent analyzeAll - Initialize all lines with
[+] during analysis phase - Update to [...] (Pending) after each
analysis completes - Uses mapConcurrentlyBounded with concurrency of
8 for analysis - Remove Log.info from analyzeOne (now handled by line
state) - Analysis now runs in parallel, improving efficiency - Flow:
[+] analyzing → [...] pending → [~] building → [✓]/[x] complete
Diffstat (limited to 'Omni/Bild.hs')
| -rwxr-xr-x | Omni/Bild.hs | 50 |
1 files changed, 26 insertions, 24 deletions
diff --git a/Omni/Bild.hs b/Omni/Bild.hs index 90f6cd6..96ea9e9 100755 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -187,7 +187,7 @@ test_bildBild = case Namespace.fromPath root path of Nothing -> Test.assertFailure "can't find ns for bild" Just ns -> - analyze mempty ns + analyzeAll [ns] +> build False False 1 2 +> \case [Exit.ExitFailure _] -> @@ -204,7 +204,7 @@ test_bildExamples = |> traverse Dir.makeAbsolute /> map (Namespace.fromPath root) /> catMaybes - +> foldM analyze mempty + +> analyzeAll +> build False False 4 1 +> \case [] -> Test.assertFailure "asdf" @@ -214,15 +214,16 @@ move :: Cli.Arguments -> IO () move args = do IO.hSetBuffering stdout IO.NoBuffering root <- Env.getEnv "CODEROOT" - Cli.getAllArgs args (Cli.argument "target") - |> filterM Dir.doesFileExist - +> filterGitIgnored - /> filter (\x -> isGitHook x |> don't) - +> traverse Dir.makeAbsolute - +> traverse (namespaceFromPathOrDie root) - /> filter isBuildableNs - +> foldM analyze mempty - +> printOrBuild root + namespaces <- + Cli.getAllArgs args (Cli.argument "target") + |> filterM Dir.doesFileExist + +> filterGitIgnored + /> filter (\x -> isGitHook x |> don't) + +> traverse Dir.makeAbsolute + +> traverse (namespaceFromPathOrDie root) + /> filter isBuildableNs + analysis <- analyzeAll namespaces + printOrBuild root analysis |> Timeout.timeout (toMillis minutes) +> \case Nothing -> @@ -439,7 +440,7 @@ dev_getTarget fp = do |> \case Nothing -> panic "Could not get namespace from path" Just ns -> - analyze mempty ns + analyzeAll [ns] /> Map.lookup ns /> \case Nothing -> panic "Could not retrieve target from analysis" @@ -527,22 +528,21 @@ 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 +analyzeAll :: [Namespace] -> IO Analysis +analyzeAll nss = do + LogC.withLineManager nss <| \lineMgr -> do + LogC.initializeLines lineMgr + targets <- mapConcurrentlyBounded 8 (analyzeOne lineMgr) nss + pure <| Map.fromList <| catMaybes <| zipWith (\ns mt -> (ns,) </ mt) nss targets where - analyzeOne :: Namespace -> IO (Maybe Target) - analyzeOne namespace@(Namespace parts ext) = do + analyzeOne :: LogC.LineManager -> Namespace -> IO (Maybe Target) + analyzeOne _lineMgr 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.wipe >> Log.info ["+", nschunk namespace] contentLines <- withFile abspath ReadMode <| \h -> IO.hSetEncoding h IO.utf8_bom @@ -552,7 +552,7 @@ analyze hmap ns = case Map.lookup ns hmap of -- dot-separated namespace instead isExe <- Dir.getPermissions quapath /> Dir.executable let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing) - case ext of + result <- case ext of -- basically we don't support building these Namespace.Css -> pure Nothing Namespace.Json -> pure Nothing @@ -565,7 +565,7 @@ analyze hmap ns = case Map.lookup ns hmap of contentLines |> Meta.detectAll "#" |> \Meta.Parsed {..} -> - detectPythonImports hmap contentLines +> \srcs -> + detectPythonImports mempty contentLines +> \srcs -> Target { builder = "python", wrapper = Nothing, @@ -620,7 +620,7 @@ analyze hmap ns = case Map.lookup ns hmap of contentLines |> Meta.detectAll "--" |> \Meta.Parsed {..} -> - detectHaskellImports hmap contentLines +> \(langdeps, srcs) -> + detectHaskellImports mempty contentLines +> \(langdeps, srcs) -> Target { builder = "haskell", wrapper = Nothing, @@ -789,6 +789,8 @@ analyze hmap ns = case Map.lookup ns hmap of } |> Just |> pure + LogC.updateLineState namespace LogC.Pending + pure result detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath) detectHaskellImports _ contentLines = do |
