From 846116c28c76cbca45601bd5304cabf0105288ba Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Wed, 26 Oct 2022 12:37:12 -0400 Subject: Factor out metadata handling into Biz.Bild.Meta The code was becoming repetitive and messy, with functions like 'metaDep' and so on. So that's an indication that they just need to have their own home. --- Biz/Bild.hs | 482 ++++++++++++++++++++++++------------------------------- Biz/Bild/Meta.hs | 90 +++++++++++ 2 files changed, 298 insertions(+), 274 deletions(-) create mode 100644 Biz/Bild/Meta.hs (limited to 'Biz') diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 35932b5..ae9244a 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -104,6 +104,7 @@ module Biz.Bild where import Alpha hiding (sym, (<.>)) +import qualified Biz.Bild.Meta as Meta import qualified Biz.Cli as Cli import qualified Biz.Log as Log import Biz.Namespace (Namespace (..)) @@ -209,20 +210,6 @@ exitSummary exits = where failures = length <| filter isFailure exits -type Dep = String - -type Arg = String - -data Out = Lib String | Bin String | None - deriving (Show, Eq) - -instance Aeson.ToJSON Out where - toJSON = - Aeson.String <. Text.pack <. \case - Bin a -> a - Lib a -> a - None -> "" - data Compiler = Copy | Gcc @@ -251,17 +238,18 @@ instance ToNixFlag Compiler where data Target = Target { -- | Output name - out :: Out, + out :: Meta.Out, -- | Output path (into cabdir) outPath :: FilePath, -- | Fully qualified namespace partitioned by '.' namespace :: Namespace, -- | Absolute path to file path :: FilePath, - -- | Language-specific dependencies - langdeps :: Set Dep, - -- | System-level dependencies - sysdeps :: Set Dep, + -- | Language-specific dependencies, required during compilation + langdeps :: Set Meta.Dep, + -- | System-level dependencies, required during runtime either via PATH or + -- linking, depending on the language + sysdeps :: Set Meta.Dep, -- | Which compiler should we use? compiler :: Compiler, -- | Where is this machine being built? @@ -327,24 +315,24 @@ cab = /> fromMaybe "_" |> unsafePerformIO --- | Emulate the *nix hierarchy in the cabdir. -outToPath :: Out -> FilePath +outToPath :: Meta.Out -> FilePath outToPath = \case - Bin o -> cab "bin" o - Lib o -> cab "lib" o - None -> mempty + Meta.Bin o -> cab "bin" o + Meta.Lib o -> cab "lib" o + Meta.None -> mempty intdir, nixdir, vardir :: FilePath intdir = cab "int" nixdir = cab "nix" vardir = cab "var" +-- | Emulate the *nix hierarchy in the cabdir. createHier :: String -> IO () createHier root = traverse_ (Dir.createDirectoryIfMissing True) - [ root (outToPath <| Bin ""), - root (outToPath <| Lib ""), + [ root (outToPath <| Meta.Bin ""), + root (outToPath <| Meta.Lib ""), root intdir, root nixdir, root vardir @@ -369,16 +357,17 @@ analyze hmap ns = case Map.lookup ns hmap of analyzeOne :: Namespace -> IO (Maybe Target) analyzeOne namespace@(Namespace _ ext) = do let path = Namespace.toPath namespace - content <- + contentLines <- withFile path ReadMode <| \h -> IO.hSetEncoding h IO.utf8_bom >> Text.IO.hGetContents h - let contentLines = Text.lines content + /> Text.lines root <- Env.getEnv "BIZ_ROOT" absPath <- Dir.makeAbsolute path user <- Env.getEnv "USER" /> Text.pack host <- Env.lookupEnv "HOSTNAME" /> fromMaybe "interactive" /> Text.pack Log.info ["bild", "analyze", str path] + let runw cmd args = Process.readProcess cmd args "" /> Text.pack /> Text.words case ext of -- basically we don't support building these Namespace.Css -> pure Nothing @@ -388,225 +377,197 @@ analyze hmap ns = case Map.lookup ns hmap of Namespace.None -> pure Nothing Namespace.Py -> pure Nothing Namespace.Sh -> pure Nothing - Namespace.C -> do - let out = detectOut (metaOut "//" <|> metaLib "//") contentLines - let args = detectMeta (metaArg "//") contentLines - let langdeps = detectMeta (metaDep "//") contentLines - langdepFlags <- - if null langdeps - then pure [] - else - Process.readProcess - "pkg-config" - ("--cflags" : Set.toList langdeps) - "" - /> Text.pack - /> Text.words - - let sysdeps = detectMeta (metaSys "//") contentLines - sysdepFlags <- - if null sysdeps - then pure [] - else - Process.readProcess - "pkg-config" - ("--libs" : Set.toList sysdeps) - "" - /> Text.pack - /> Text.words - Target - { langdeps = Set.empty, -- c has no lang deps...? - wrapper = Nothing, - compiler = Gcc, - builder = Local <| user, - compilerFlags = - concat - [ [o, dir, Text.pack absPath] - ++ langdepFlags - ++ sysdepFlags - ++ (map Text.pack <| Set.toList args) - | let outable = out /= None, - o <- outable ?: (["-o"], []), - dir <- outable ?: ([Text.pack <| root outToPath out], []) - ], - outPath = outToPath out, - .. - } - |> Just - |> pure - Namespace.Hs -> do - langdeps <- detectHaskellImports contentLines - let out = detectOut (metaOut "--") contentLines - Just - root, - "-odir", - root intdir, - "-hidir", - root intdir, - "--make", - path - ] - ++ (out /= None) - ?: ( map - Text.pack - [ "-main-is", - Namespace.toHaskellModule namespace, - "-o", - root outToPath out - ], - [] - ), - sysdeps = detectMeta (metaSys "--") contentLines, - outPath = outToPath out, - .. - } - Namespace.Lisp -> do - let out = detectOut (metaOut ";;") contentLines - langdeps <- detectLispImports contentLines - Just - (root outToPath out) <> "\" :toplevel #'main :executable t)" - ], - builder = Local <| user, - outPath = outToPath out, - .. - } - Namespace.Nix -> do - let builder = - (host == "lithium") - ?: ( Local user, - Remote user "dev.simatime.com" - ) - Just - nixdir Namespace.toPath namespace, - "--builders", - toNixFlag builder - ], - out = None, - outPath = outToPath None, - .. - } - Namespace.Scm -> do - let out = detectOut (metaOut ";;") contentLines - Just - intdir replaceExtension path ".scm.go", - path - ], - builder = Local user, - outPath = outToPath out, - wrapper = - Just <| Text.pack - <| joinWith - "\n" - [ "#!/usr/bin/env bash", - "guile -C \"" - <> root intdir - <> "\" -e main " - <> "-s " - <> Namespace.toPath namespace - <> " \"$@\"" + Namespace.C -> + Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do + langdepFlags <- + null pdep + ?. ( runw "pkg-config" ("--cflags" : Set.toList pdep), + pure [] + ) + sysdepFlags <- + null psys + ?. ( runw "pkg-config" ("--libs" : Set.toList psys), + pure [] + ) + Target + { langdeps = pdep, + sysdeps = psys, + wrapper = Nothing, + compiler = Gcc, + builder = Local user, + out = pout, + compilerFlags = + concat + [ [o, dir, Text.pack absPath] + ++ langdepFlags + ++ sysdepFlags + ++ (map Text.pack <| Set.toList parg) + | let outable = pout /= Meta.None, + o <- outable ?: (["-o"], []), + dir <- outable ?: ([Text.pack <| root outToPath pout], []) + ], + outPath = outToPath pout, + .. + } + |> Just + |> pure + Namespace.Hs -> + Meta.detectOut (Meta.out "--") contentLines |> \out -> do + langdeps <- detectHaskellImports contentLines + Target + { builder = Local user, + wrapper = Nothing, + compiler = Ghc, + compilerFlags = + [ "-Werror", + "-i" <> root, + "-odir", + root intdir, + "-hidir", + root intdir, + "--make", + absPath + ] + ++ (out /= Meta.None) + ?: ( [ "-main-is", + Namespace.toHaskellModule namespace, + "-o", + root outToPath out + ], + [] + ) + |> map Text.pack, + sysdeps = Meta.detect (Meta.sys "--") contentLines, + outPath = outToPath out, + .. + } + |> Just + |> pure + Namespace.Lisp -> + Meta.detectOut (Meta.out ";;") contentLines |> \out -> do + langdeps <- detectLispImports contentLines + Just + (root outToPath out) <> "\" :toplevel #'main :executable t)" ], - .. - } - Namespace.Rs -> do - let out = detectOut (metaOut "//") contentLines - Just - outToPath out], - builder = Local user, - outPath = outToPath out, - .. - } - detectHaskellImports :: [Text] -> IO (Set Dep) - detectHaskellImports contentLines = do - let imports = - contentLines - /> Text.unpack - /> 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 - /> mconcat - pure <| pkgs <> transitivePkgs + builder = Local <| user, + outPath = outToPath out, + .. + } + Namespace.Nix -> + (host == "lithium") ?: (Local user, Remote user "dev.simatime.com") |> \builder -> + Target + { langdeps = Set.empty, + wrapper = Nothing, + sysdeps = Set.empty, + compiler = NixBuild, + compilerFlags = + [ absPath, + "--out-link", + root nixdir Namespace.toPath namespace, + "--builders", + toNixFlag builder + ] + |> map Text.pack, + out = Meta.None, + outPath = outToPath Meta.None, + .. + } + |> Just + |> pure + Namespace.Scm -> + Meta.detectOut (Meta.out ";;") contentLines |> \out -> + Target + { langdeps = Set.empty, + sysdeps = Set.empty, + compiler = Guile, + compilerFlags = + [ "compile", + "--r7rs", + "--load-path=" ++ root, + "--output=" ++ root intdir replaceExtension path ".scm.go", + absPath + ] + |> map Text.pack, + builder = Local user, + outPath = outToPath out, + wrapper = + [ "#!/usr/bin/env bash", + "guile -C \"" + <> root intdir + <> "\" -e main " + <> "-s " + <> Namespace.toPath namespace + <> " \"$@\"" + ] + |> joinWith "\n" + |> Text.pack + |> Just, + .. + } + |> Just + |> pure + Namespace.Rs -> + Meta.detectOut (Meta.out "//") contentLines |> \out -> + Target + { langdeps = Set.empty, + wrapper = Nothing, + sysdeps = Set.empty, + compiler = Rustc, + compilerFlags = map Text.pack [absPath, "-o", root outToPath out], + builder = Local user, + outPath = outToPath out, + .. + } + |> Just + |> pure + fromPath :: String -> IO (Maybe Namespace) --String ->IO (Maybe Namespace) + fromPath x = + Env.getEnv "BIZ_ROOT" +> \root -> + pure <| Namespace.fromPath root x + detectHaskellImports :: [Text] -> IO (Set Meta.Dep) + detectHaskellImports contentLines = + contentLines + /> Text.unpack + /> Regex.match haskellImports + |> catMaybes + |> \imports -> + foldM ghcPkgFindModule Set.empty imports + +> \pkgs -> + imports + |> map Namespace.fromHaskellModule + |> map Namespace.toPath + |> traverse Dir.makeAbsolute + +> filterM Dir.doesFileExist + +> traverse fromPath + /> 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 + /> mconcat + /> (<> pkgs) + + detectLispImports :: [Text] -> IO (Set Meta.Dep) detectLispImports contentLines = do let requires = contentLines /> Text.unpack /> Regex.match lispRequires |> catMaybes pure <| Set.fromList requires - detectOut m cl = - cl - /> Text.unpack - /> Regex.match m - |> catMaybes - |> head - |> fromMaybe None - detectMeta m cl = - cl - /> Text.unpack - /> Regex.match m - |> catMaybes - |> Set.fromList ghcPkgFindModule :: Set String -> String -> IO (Set String) ghcPkgFindModule acc m = do @@ -655,17 +616,17 @@ build andTest loud analysis = do >> proc loud namespace compiler compilerFlags where label = case out of - Bin _ -> "bin" + Meta.Bin _ -> "bin" _ -> "lib" Ghc -> case out of - None -> pure Exit.ExitSuccess - Bin _ -> do + Meta.None -> pure Exit.ExitSuccess + Meta.Bin _ -> do Log.info ["bild", "dev", "ghc-exe", nschunk namespace] exitcode <- proc loud namespace compiler compilerFlags if andTest && isSuccess exitcode then test loud target else pure exitcode - Lib _ -> do + Meta.Lib _ -> do Log.info ["bild", "dev", "ghc-lib", nschunk namespace] proc loud namespace compiler compilerFlags Guile -> do @@ -757,33 +718,6 @@ logs ns src = nschunk :: Namespace -> Text nschunk = Namespace.toPath .> Text.pack -metaDep :: [Char] -> Regex.RE Char Dep -metaDep comment = - Regex.string (comment ++ " : dep ") - *> Regex.many (Regex.psym (not <. Char.isSpace)) - -metaSys :: [Char] -> Regex.RE Char Dep -metaSys comment = - Regex.string (comment ++ " : sys ") - *> Regex.many (Regex.psym (not <. Char.isSpace)) - -metaOut :: [Char] -> Regex.RE Char Out -metaOut comment = - Regex.string (comment ++ " : out ") - *> Regex.many (Regex.psym (/= ' ')) - /> Bin - -metaLib :: [Char] -> Regex.RE Char Out -metaLib comment = - Regex.string (comment ++ " : lib ") - *> Regex.many (Regex.psym (/= ' ')) - /> Lib - -metaArg :: [Char] -> Regex.RE Char Arg -metaArg comment = - Regex.string (comment ++ " : arg ") - *> Regex.many Regex.anySym - haskellImports :: Regex.RE Char String haskellImports = Regex.string "import" diff --git a/Biz/Bild/Meta.hs b/Biz/Bild/Meta.hs new file mode 100644 index 0000000..75242a5 --- /dev/null +++ b/Biz/Bild/Meta.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Small module for extracting metadata from the comments of modules. +module Biz.Bild.Meta where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.Char as Char +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Text.Regex.Applicative as Regex + +type Dep = String + +type Sys = String + +type Arg = String + +data Out = Lib String | Bin String | None + deriving (Show, Eq) + +instance Aeson.ToJSON Out where + toJSON = + Aeson.String <. Text.pack <. \case + Bin a -> a + Lib a -> a + None -> "" + +data Parsed = Parsed + { pdep :: Set Dep, + parg :: Set Arg, + pout :: Out, + psys :: Set Sys + } + +detect :: Ord a => Regex.RE Char a -> [Text] -> Set a +detect m cl = + cl + /> Text.unpack + /> Regex.match m + |> catMaybes + |> Set.fromList + +-- | 'Out' is always singular, so it gets a special function +detectOut :: Regex.RE Char Out -> [Text] -> Out +detectOut m cl = + cl + /> Text.unpack + /> Regex.match m + |> catMaybes + |> head + |> fromMaybe None + +detectAll :: [Char] -> [Text] -> Parsed +detectAll m cl = Parsed {..} + where + pout = detectOut (out m <|> lib m) cl + detect_ re = detect (re m) cl + pdep = detect_ dep + psys = detect_ sys + parg = detect_ arg + +dep :: [Char] -> Regex.RE Char Dep +dep comment = + Regex.string (comment ++ " : dep ") + *> Regex.many (Regex.psym (not <. Char.isSpace)) + +sys :: [Char] -> Regex.RE Char Dep +sys comment = + Regex.string (comment ++ " : sys ") + *> Regex.many (Regex.psym (not <. Char.isSpace)) + +out :: [Char] -> Regex.RE Char Out +out comment = + Regex.string (comment ++ " : out ") + *> Regex.many (Regex.psym (/= ' ')) + /> Bin + +lib :: [Char] -> Regex.RE Char Out +lib comment = + Regex.string (comment ++ " : lib ") + *> Regex.many (Regex.psym (/= ' ')) + /> Lib + +arg :: [Char] -> Regex.RE Char Arg +arg comment = + Regex.string (comment ++ " : arg ") + *> Regex.many Regex.anySym -- cgit v1.2.3