diff options
| -rwxr-xr-x | Omni/Bild.hs | 50 | ||||
| -rw-r--r-- | Omni/Log/Concurrent.hs | 6 |
2 files changed, 30 insertions, 26 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 diff --git a/Omni/Log/Concurrent.hs b/Omni/Log/Concurrent.hs index b064190..1a82507 100644 --- a/Omni/Log/Concurrent.hs +++ b/Omni/Log/Concurrent.hs @@ -26,7 +26,7 @@ import qualified System.Environment as Env import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) -data BuildState = Pending | Building | Success | Failed +data BuildState = Analyzing | Pending | Building | Success | Failed deriving (Eq, Show) data LineManager = LineManager @@ -92,7 +92,7 @@ initializeLines LineManager {..} = ANSI.hSetCursorColumn IO.stderr 0 ANSI.hClearLine IO.stderr let nsText = Text.pack (Namespace.toPath ns) - IO.hPutStrLn IO.stderr (Text.unpack <| "[…] " <> nsText) + IO.hPutStrLn IO.stderr (Text.unpack <| "[+] " <> nsText) IO.hFlush IO.stderr updateLine :: Namespace -> Text -> IO () @@ -146,6 +146,8 @@ updateLineState ns buildState = do Rainbow.hPutChunks IO.stderr [fore green <| chunk <| "[✓] " <> nsText] Failed -> Rainbow.hPutChunks IO.stderr [fore red <| chunk <| "[x] " <> nsText] + Analyzing -> + IO.hPutStr IO.stderr (Text.unpack <| "[+] " <> nsText) Pending -> IO.hPutStr IO.stderr (Text.unpack <| "[…] " <> nsText) Building -> |