diff options
Diffstat (limited to 'Biz')
| -rw-r--r-- | Biz/Bild.hs | 422 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 26 |
2 files changed, 236 insertions, 212 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 127b6a7..06c102f 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -133,7 +133,9 @@ main = Cli.main <| Cli.Plan help move test_ pure Test.group "Biz.Bild" [ Test.unit "can bild bild" <| do - analyze mempty "Biz/Bild.hs" + root <- Env.getEnv "BIZ_ROOT" + let Just ns = Namespace.fromPath root "Biz/Bild.hs" + analyze mempty ns /> Map.elems +> traverse (build False False) +> \case @@ -144,11 +146,15 @@ main = Cli.main <| Cli.Plan help move test_ pure ] move :: Cli.Arguments -> IO () -move args = +move args = do + root <- Env.getEnv "BIZ_ROOT" IO.hSetBuffering stdout IO.NoBuffering >> pure (Cli.getAllArgs args (Cli.argument "target")) /> filter (not <. Namespace.isCab) +> filterM Dir.doesFileExist + +> traverse Dir.makeAbsolute + /> map (Namespace.fromPath root) + /> catMaybes +> foldM analyze mempty /> Map.filter (namespace .> isBuildableNs) /> Map.elems @@ -302,19 +308,18 @@ removeVersion = takeWhile (/= '.') .> butlast2 where butlast2 s = take (length s - 2) s -type Analysis = Map FilePath Target +type Analysis = Map Namespace 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 :: Analysis -> FilePath -> IO Analysis -analyze hmap path_ = case Map.lookup path_ hmap of +analyze :: Analysis -> Namespace -> IO Analysis +analyze hmap ns = case Map.lookup ns hmap of Nothing -> do - mTarget <- analyze' path_ - pure <| maybe hmap (\t -> Map.insert path_ t hmap) mTarget + mTarget <- analyzeOne ns + pure <| maybe hmap (\t -> Map.insert ns t hmap) mTarget Just _ -> pure hmap where - analyze' :: FilePath -> IO (Maybe Target) - analyze' path = do + analyzeOne :: Namespace -> IO (Maybe Target) + analyzeOne namespace@(Namespace _ ext) = do + let path = Namespace.toPath namespace content <- withFile path ReadMode <| \h -> IO.hSetEncoding h IO.utf8_bom @@ -325,202 +330,197 @@ analyze hmap path_ = case Map.lookup path_ hmap of 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 = - 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", - .. - } + 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 = + 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 = @@ -529,11 +529,19 @@ analyze hmap path_ = case Map.lookup path_ hmap of /> Regex.match haskellImports |> catMaybes pkgs <- foldM ghcPkgFindModule Set.empty imports + root <- Env.getEnv "BIZ_ROOT" transitivePkgs <- imports |> map (Namespace.fromHaskellModule .> Namespace.toPath) |> traverse Dir.makeAbsolute +> filterM Dir.doesFileExist + /> map (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 hmap /> Map.elems /> map langdeps diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs index 6fb40f7..cdc4464 100644 --- a/Biz/Namespace.hs +++ b/Biz/Namespace.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -37,10 +38,10 @@ data Ext | Rs | Scm | Sh - deriving (Eq, Show, Generic, Aeson.ToJSON) + deriving (Eq, Show, Generic, Aeson.ToJSON, Ord) data Namespace = Namespace {path :: [String], ext :: Ext} - deriving (Eq, Show, Generic, Aeson.ToJSON) + deriving (Eq, Show, Generic, Aeson.ToJSON, Ord) fromPath :: String -> String -> Maybe Namespace fromPath bizRoot absPath = @@ -50,9 +51,24 @@ fromPath bizRoot absPath = toPath :: Namespace -> FilePath toPath (Namespace parts ext) = - joinWith "/" parts - <> "." - <> lowercase (show ext) + joinWith "/" parts <> toExt ext + +toExt :: Ext -> String +toExt = + ("." <>) <. \case + C -> "c" + Css -> "css" + Hs -> "hs" + Json -> "json" + Keys -> "pub" + Lisp -> "lisp" + Md -> "md" + Nix -> "nix" + None -> "none" + Py -> "py" + Rs -> "rs" + Scm -> "scm" + Sh -> "sh" fromHaskellContent :: String -> Maybe Namespace fromHaskellContent c = case Regex.findFirstInfix haskellModule c of |