diff options
| -rw-r--r--[-rwxr-xr-x] | Omni/Bild.hs | 178 |
1 files changed, 138 insertions, 40 deletions
diff --git a/Omni/Bild.hs b/Omni/Bild.hs index 02e411b..e8c2f09 100755..100644 --- a/Omni/Bild.hs +++ b/Omni/Bild.hs @@ -130,6 +130,7 @@ 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 qualified Data.List as List import qualified Data.Map as Map @@ -151,7 +152,7 @@ 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, takeDirectory, (</>)) +import System.FilePath (dropExtension, replaceExtension, takeDirectory, (</>)) import qualified System.IO as IO import System.IO.Unsafe (unsafePerformIO) import qualified System.Process as Process @@ -431,7 +432,24 @@ 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) @@ -592,6 +610,7 @@ analyzeAll nss = do packageSet = "python.packages", mainModule = Namespace.toModule namespace, rundeps = prun, + hsGraph = Nothing, .. } |> Just @@ -616,6 +635,7 @@ analyzeAll nss = do -- implement detectCImports, then I can fill this out srcs = Set.empty, rundeps = prun, + hsGraph = Nothing, .. } |> Just @@ -624,44 +644,46 @@ analyzeAll nss = do contentLines |> Meta.detectAll "--" |> \Meta.Parsed {..} -> - detectHaskellImports mempty contentLines +> \(langdeps, srcs) -> - Target - { builder = "haskell", - wrapper = Nothing, - compiler = Ghc, - packageSet = "haskell.packages", - mainModule = Namespace.toModule namespace, - compilerFlags = - [ "-Wall", - "-Werror", - "-haddock", - "-Winvalid-haddock", - "-threaded", - "-i$CODEROOT", - "-odir", - ".", - "-hidir", - ".", - "--make", - "$CODEROOT" </> quapath - ] - ++ case pout of - Just o -> - [ "-main-is", - Namespace.toHaskellModule namespace, - "-o", - o - ] - Nothing -> [] - |> map Text.pack, - sysdeps = Meta.detect (Meta.sys "--") contentLines, - outPath = outToPath pout, - rundeps = prun, - out = pout <|> defaultOut, - .. - } - |> Just - |> pure + detectHaskellImports mempty contentLines +> \(langdeps, srcs) -> do + graph <- buildHsModuleGraph namespace srcs + pure + <| Just + Target + { builder = "haskell", + wrapper = Nothing, + compiler = Ghc, + packageSet = "haskell.packages", + mainModule = Namespace.toModule namespace, + compilerFlags = + [ "-Wall", + "-Werror", + "-haddock", + "-Winvalid-haddock", + "-threaded", + "-i$CODEROOT", + "-odir", + ".", + "-hidir", + ".", + "--make", + "$CODEROOT" </> quapath + ] + ++ case pout of + Just o -> + [ "-main-is", + Namespace.toHaskellModule namespace, + "-o", + o + ] + Nothing -> [] + |> map Text.pack, + sysdeps = Meta.detect (Meta.sys "--") contentLines, + outPath = outToPath pout, + rundeps = prun, + out = pout <|> defaultOut, + hsGraph = graph, + .. + } Namespace.Lisp -> Meta.detectOut (Meta.out ";;") contentLines |> \out -> do langdeps <- detectLispImports contentLines @@ -688,6 +710,7 @@ analyzeAll nss = do -- add local src imports to detectLispImports, then i can fill this out srcs = Set.empty, rundeps = Set.empty, + hsGraph = Nothing, .. } Namespace.Nix -> @@ -715,6 +738,7 @@ analyzeAll nss = do mainModule = Namespace.toModule namespace, builder = "base", rundeps = Set.empty, + hsGraph = Nothing, .. } |> Just @@ -758,6 +782,7 @@ analyzeAll nss = do |> Just ), rundeps = prun, + hsGraph = Nothing, .. } |> Just @@ -789,6 +814,7 @@ analyzeAll nss = do -- implement detectRustImports srcs = Set.empty, rundeps = prun, + hsGraph = Nothing, .. } |> Just @@ -986,6 +1012,78 @@ ghcPkgFindModule acc m = /> Set.fromList /> Set.union acc +-- | Build module graph for Haskell targets, returns Nothing if TH or cycles detected +buildHsModuleGraph :: Namespace -> Set FilePath -> IO (Maybe HsModuleGraph) +buildHsModuleGraph namespace srcs = do + root <- Env.getEnv "CODEROOT" + nodes <- foldM (analyzeModule root) Map.empty (Set.toList srcs) + let hasTH = any nodeHasTH (Map.elems nodes) + let hasCycles = detectCycles nodes + if hasTH || hasCycles + then pure Nothing + else + pure + <| Just + HsModuleGraph + { graphEntry = Namespace.toHaskellModule namespace |> Text.pack, + graphModules = nodes + } + 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 |