summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Biz/Bild.hs482
-rw-r--r--Biz/Bild/Meta.hs90
2 files changed, 298 insertions, 274 deletions
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
- </ pure
- Target
- { builder = Local <| user,
- wrapper = Nothing,
- compiler = Ghc,
- 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 </> outToPath out
- ],
- []
- ),
- sysdeps = detectMeta (metaSys "--") contentLines,
- outPath = outToPath out,
- ..
- }
- Namespace.Lisp -> do
- let out = detectOut (metaOut ";;") contentLines
- langdeps <- detectLispImports contentLines
- Just
- </ pure
- Target
- { sysdeps = Set.empty,
- wrapper = Nothing,
- compiler = Sbcl,
- compilerFlags =
- map
- Text.pack
- [ "--eval",
- "(require :asdf)",
- "--load",
- path,
- "--eval",
- "(sb-ext:save-lisp-and-die #p\"" <> (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
- </ pure
- Target
- { langdeps = Set.empty,
- wrapper = Nothing,
- sysdeps = Set.empty,
- compiler = NixBuild,
- compilerFlags =
- map
- Text.pack
- [ path,
- "--out-link",
- root </> nixdir </> Namespace.toPath namespace,
- "--builders",
- toNixFlag builder
- ],
- out = None,
- outPath = outToPath None,
- ..
- }
- Namespace.Scm -> do
- let out = detectOut (metaOut ";;") contentLines
- 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 = 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
+ </ pure
+ Target
+ { sysdeps = Set.empty,
+ wrapper = Nothing,
+ compiler = Sbcl,
+ compilerFlags =
+ map
+ Text.pack
+ [ "--eval",
+ "(require :asdf)",
+ "--load",
+ absPath,
+ "--eval",
+ "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)"
],
- ..
- }
- Namespace.Rs -> do
- let out = detectOut (metaOut "//") contentLines
- Just
- </ pure
- Target
- { langdeps = Set.empty,
- wrapper = Nothing,
- sysdeps = Set.empty,
- compiler = Rustc,
- compilerFlags = map Text.pack [path, "-o", root </> 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 07:22:43 +0000