diff options
| -rw-r--r-- | Biz/Bild.hs | 441 |
1 files changed, 224 insertions, 217 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index f23d04a..127b6a7 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -113,7 +113,7 @@ import Data.Conduit ((.|)) import qualified Data.Conduit as Conduit import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.Process as Conduit -import qualified Data.Maybe as Maybe +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.String as String import qualified Data.Text as Text @@ -133,11 +133,11 @@ main = Cli.main <| Cli.Plan help move test_ pure Test.group "Biz.Bild" [ Test.unit "can bild bild" <| do - analyze "Biz/Bild.hs" - /> Maybe.fromJust - +> build False False + analyze mempty "Biz/Bild.hs" + /> Map.elems + +> traverse (build False False) +> \case - Exit.ExitFailure _ -> + [Exit.ExitFailure _] -> Test.assertFailure "can't bild bild" _ -> pure () @@ -149,10 +149,9 @@ move args = >> pure (Cli.getAllArgs args (Cli.argument "target")) /> filter (not <. Namespace.isCab) +> filterM Dir.doesFileExist - +> traverse analyze - /> filter isJust - /> map Maybe.fromJust - /> filter (namespace .> isBuildableNs) + +> foldM analyze mempty + /> Map.filter (namespace .> isBuildableNs) + /> Map.elems +> printOrBuild +> exitSummary where @@ -303,217 +302,225 @@ removeVersion = takeWhile (/= '.') .> butlast2 where butlast2 s = take (length s - 2) s +type Analysis = Map FilePath Target + -- | TODO: globally cache analyses, so I'm not re-analyzing modules all the -- time. This is important as it would speed up building by a lot. -analyze :: FilePath -> IO (Maybe Target) -analyze path = do - content <- - withFile path ReadMode <| \h -> - IO.hSetEncoding h IO.utf8_bom - >> Text.IO.hGetContents h - let contentLines = Text.lines content - root <- Env.getEnv "BIZ_ROOT" - absPath <- Dir.makeAbsolute path - user <- Env.getEnv "USER" /> Text.pack - host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME" - Log.info ["bild", "analyze", str path] - case Namespace.fromPath root absPath of - Nothing -> - Log.warn ["bild", "analyze", str path, "could not find namespace"] - >> Log.br - >> pure Nothing - Just namespace@(Namespace _ ext) -> 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.Py -> pure Nothing - Namespace.Sh -> pure Nothing - Namespace.C -> do - let out = - contentLines - /> Text.unpack - /> Regex.match (metaOut "//" <|> metaLib "//") - |> catMaybes - |> head - |> fromMaybe None - let sysdeps = - contentLines - /> Text.unpack - /> Regex.match (metaSys "//") - |> catMaybes - |> Set.fromList - guileFlags <- - if "guile_3_0" `elem` sysdeps - then - Process.readProcess "guile-config" ["compile"] "" - /> String.words - /> (++ ["-shared", "-fPIC"]) - /> map Text.pack - else pure mempty - Just - </ pure - Target - { langdeps = Set.empty, -- c has no lang deps...? - compiler = Gcc, - builder = user <> "@localhost", - compilerFlags = - concat - [ [o, dir, Text.pack absPath] ++ guileFlags - | let outable = out /= None, - o <- outable ?: (["-o"], []), - dir <- outable ?: ([Text.pack <| root </> outdir out], []) - ], - .. - } - Namespace.Hs -> do - langdeps <- detectHaskellImports contentLines - let out = - contentLines - /> Text.unpack - /> Regex.match (metaOut "--") - |> catMaybes - |> head - |> fromMaybe None - Just - </ pure - Target - { builder = user <> "@localhost", - compiler = detectGhcCompiler out, - compilerFlags = - map - Text.pack - [ "-Werror", - "-i" <> root, - "-odir", - root </> intdir, - "-hidir", - root </> intdir, - "--make", - path - ] - ++ (out /= None) - ?: ( map - Text.pack - [ "-main-is", - Namespace.toHaskellModule namespace, - "-o", - root </> outdir out - ], - [] - ), - sysdeps = +analyze :: Analysis -> FilePath -> IO Analysis +analyze hmap path_ = case Map.lookup path_ hmap of + Nothing -> do + mTarget <- analyze' path_ + pure <| maybe hmap (\t -> Map.insert path_ t hmap) mTarget + Just _ -> pure hmap + where + analyze' :: FilePath -> IO (Maybe Target) + analyze' path = do + content <- + withFile path ReadMode <| \h -> + IO.hSetEncoding h IO.utf8_bom + >> Text.IO.hGetContents h + let contentLines = Text.lines content + root <- Env.getEnv "BIZ_ROOT" + absPath <- Dir.makeAbsolute path + user <- Env.getEnv "USER" /> Text.pack + host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME" + Log.info ["bild", "analyze", str path] + case Namespace.fromPath root absPath of + Nothing -> + Log.warn ["bild", "analyze", str path, "could not find namespace"] + >> Log.br + >> pure Nothing + Just namespace@(Namespace _ ext) -> 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.Py -> pure Nothing + Namespace.Sh -> pure Nothing + Namespace.C -> do + let out = contentLines /> Text.unpack - /> Regex.match (metaSys "--") + /> Regex.match (metaOut "//" <|> metaLib "//") |> catMaybes - |> Set.fromList, - .. - } - Namespace.Lisp -> do - let out = - contentLines - /> Text.unpack - /> Regex.match (metaOut ";;") - |> catMaybes - |> head - |> fromMaybe None - langdeps <- detectLispImports contentLines - Just - </ pure - Target - { sysdeps = Set.empty, - compiler = Sbcl, - compilerFlags = - map - Text.pack - [ "--load", - path, - "--eval", - "(require :asdf)", - "--eval", - "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out) <> "\" :toplevel #'main :executable t)" - ], - builder = user <> "@localhost", - .. - } - Namespace.Nix -> do - let builder = - (host == "lithium") - ?: ( "local", - Text.concat - [ "ssh://", - user, - "@dev.simatime.com?ssh-key=/home/", - user, - "/.ssh/id_rsa" - ] - ) - Just - </ pure - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = NixBuild, - compilerFlags = - map - Text.pack - [ path, - "--out-link", - root </> nixdir </> Namespace.toPath namespace, - "--builders", - Text.unpack builder - ], - out = None, - .. - } - Namespace.Scm -> do - let out = - contentLines - /> Text.unpack - /> Regex.match (metaOut ";;") - |> catMaybes - |> head - |> fromMaybe None - Just - </ pure - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = Guile, - compilerFlags = - map - Text.pack - [ "compile", - "--r7rs", - "--load-path=" ++ root, - "--output=" ++ root </> intdir </> replaceExtension path ".scm.go", - path - ], - builder = user <> "@localhost", - .. - } - Namespace.Rs -> do - let out = - contentLines - /> Text.unpack - /> Regex.match (metaOut "//") - |> catMaybes - |> head - |> fromMaybe None - Just - </ pure - Target - { langdeps = Set.empty, - sysdeps = Set.empty, - compiler = Rustc, - compilerFlags = map Text.pack [path, "-o", root </> outdir out], - builder = user <> "@localhost", - .. - } - where + |> head + |> fromMaybe None + let sysdeps = + contentLines + /> Text.unpack + /> Regex.match (metaSys "//") + |> catMaybes + |> Set.fromList + guileFlags <- + if "guile_3_0" `elem` sysdeps + then + Process.readProcess "guile-config" ["compile"] "" + /> String.words + /> (++ ["-shared", "-fPIC"]) + /> map Text.pack + else pure mempty + Just + </ pure + Target + { langdeps = Set.empty, -- c has no lang deps...? + compiler = Gcc, + builder = user <> "@localhost", + compilerFlags = + concat + [ [o, dir, Text.pack absPath] ++ guileFlags + | let outable = out /= None, + o <- outable ?: (["-o"], []), + dir <- outable ?: ([Text.pack <| root </> outdir out], []) + ], + .. + } + Namespace.Hs -> do + langdeps <- detectHaskellImports contentLines + let out = + contentLines + /> Text.unpack + /> Regex.match (metaOut "--") + |> catMaybes + |> head + |> fromMaybe None + Just + </ pure + Target + { builder = user <> "@localhost", + compiler = detectGhcCompiler out, + compilerFlags = + map + Text.pack + [ "-Werror", + "-i" <> root, + "-odir", + root </> intdir, + "-hidir", + root </> intdir, + "--make", + path + ] + ++ (out /= None) + ?: ( map + Text.pack + [ "-main-is", + Namespace.toHaskellModule namespace, + "-o", + root </> outdir out + ], + [] + ), + sysdeps = + contentLines + /> Text.unpack + /> Regex.match (metaSys "--") + |> catMaybes + |> Set.fromList, + .. + } + Namespace.Lisp -> do + let out = + contentLines + /> Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head + |> fromMaybe None + langdeps <- detectLispImports contentLines + Just + </ pure + Target + { sysdeps = Set.empty, + compiler = Sbcl, + compilerFlags = + map + Text.pack + [ "--load", + path, + "--eval", + "(require :asdf)", + "--eval", + "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out) <> "\" :toplevel #'main :executable t)" + ], + builder = user <> "@localhost", + .. + } + Namespace.Nix -> do + let builder = + (host == "lithium") + ?: ( "local", + Text.concat + [ "ssh://", + user, + "@dev.simatime.com?ssh-key=/home/", + user, + "/.ssh/id_rsa" + ] + ) + Just + </ pure + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = NixBuild, + compilerFlags = + map + Text.pack + [ path, + "--out-link", + root </> nixdir </> Namespace.toPath namespace, + "--builders", + Text.unpack builder + ], + out = None, + .. + } + Namespace.Scm -> do + let out = + contentLines + /> Text.unpack + /> Regex.match (metaOut ";;") + |> catMaybes + |> head + |> fromMaybe None + Just + </ pure + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = Guile, + compilerFlags = + map + Text.pack + [ "compile", + "--r7rs", + "--load-path=" ++ root, + "--output=" ++ root </> intdir </> replaceExtension path ".scm.go", + path + ], + builder = user <> "@localhost", + .. + } + Namespace.Rs -> do + let out = + contentLines + /> Text.unpack + /> Regex.match (metaOut "//") + |> catMaybes + |> head + |> fromMaybe None + Just + </ pure + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = Rustc, + compilerFlags = map Text.pack [path, "-o", root </> outdir out], + builder = user <> "@localhost", + .. + } detectHaskellImports :: [Text] -> IO (Set Dep) detectHaskellImports contentLines = do let imports = @@ -527,8 +534,8 @@ analyze path = do |> map (Namespace.fromHaskellModule .> Namespace.toPath) |> traverse Dir.makeAbsolute +> filterM Dir.doesFileExist - +> Async.mapConcurrently analyze - /> catMaybes + +> foldM analyze hmap + /> Map.elems /> map langdeps /> mconcat pure <| pkgs <> transitivePkgs |