diff options
| -rw-r--r-- | Biz/Bild.hs | 128 | ||||
| -rw-r--r-- | Biz/Bild/ShellHook.sh | 2 | ||||
| -rwxr-xr-x | Biz/Bot.scm | 9 | ||||
| -rw-r--r-- | Biz/Namespace.hs | 6 | ||||
| -rw-r--r-- | Biz/Serval.scm | 9 | ||||
| -rw-r--r-- | bs/re.scm | 3 | ||||
| -rw-r--r-- | bs/repl.scm | 4 | ||||
| -rw-r--r-- | bs/test.scm | 5 |
8 files changed, 108 insertions, 58 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index cba6539..9868ef0 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -133,12 +133,13 @@ import qualified Data.Conduit as Conduit import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.Process as Conduit import qualified Data.List as List +import qualified Data.Maybe as Maybe import qualified Data.String as String import qualified Data.Text as Text import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit -import System.FilePath ((</>)) +import System.FilePath (replaceExtension, (</>)) import qualified System.IO as IO import qualified Text.Regex.Applicative as Regex import qualified Prelude @@ -209,7 +210,7 @@ data Compiler data Target = Target { -- | Output name - out :: Out, + out :: Maybe Out, -- | Fully qualified namespace partitioned by '.' namespace :: Namespace, -- | Absolute path to file @@ -223,20 +224,38 @@ data Target = Target } deriving (Show) +-- | We can't build everything yet... isBuildableNs :: Namespace -> Bool isBuildableNs (Namespace _ Namespace.Hs) = True +isBuildableNs (Namespace _ Namespace.Scm) = True isBuildableNs ns | ns `elem` nixTargets = True | otherwise = False + where + nixTargets = + [ Namespace ["Biz", "Pie"] Namespace.Nix, + Namespace ["Biz", "Que", "Prod"] Namespace.Nix, + Namespace ["Biz", "Cloud"] Namespace.Nix, + Namespace ["Biz", "Dev"] Namespace.Nix, + Namespace ["Hero", "Prod"] Namespace.Nix + ] + +-- | Emulate the *nix hierarchy in the cabdir. +bindir, intdir, nixdir, vardir :: String +bindir = "_/bin" +intdir = "_/int" +nixdir = "_/nix" +vardir = "_/var" -nixTargets :: [Namespace] -nixTargets = - [ Namespace ["Biz", "Pie"] Namespace.Nix, - Namespace ["Biz", "Que", "Prod"] Namespace.Nix, - Namespace ["Biz", "Cloud"] Namespace.Nix, - Namespace ["Biz", "Dev"] Namespace.Nix, - Namespace ["Hero", "Prod"] Namespace.Nix - ] +createHier :: String -> IO () +createHier root = + mapM_ + (Dir.createDirectoryIfMissing True) + [ root </> bindir, + root </> intdir, + root </> nixdir, + root </> vardir + ] getNamespace :: String -> IO (Maybe Namespace) getNamespace s = do @@ -254,15 +273,14 @@ analyze namespace@(Namespace.Namespace _ ext) = do content <- String.lines </ Prelude.readFile path let out = content - /> Regex.match metaOut + /> Regex.match (metaOut "--") |> catMaybes |> head - |> fromMaybe mempty - let compiler = detectGhcCompiler out <| String.unlines content return Target { deps = content /> Regex.match metaDep |> catMaybes, builder = user <> "@localhost", + compiler = detectGhcCompiler out <| String.unlines content, .. } Namespace.Nix -> @@ -270,7 +288,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do Target { deps = [], compiler = NixBuild, - out = "", + out = Nothing, builder = if host == "lithium" then mempty @@ -284,12 +302,17 @@ analyze namespace@(Namespace.Namespace _ ext) = do ], .. } - Namespace.Scm -> + Namespace.Scm -> do + content <- String.lines </ Prelude.readFile path return Target { deps = [], compiler = Guile, - out = "", + out = + content + /> Regex.match (metaOut ";;") + |> catMaybes + |> head, builder = user <> "@localhost", .. } @@ -298,7 +321,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do Target { deps = [], compiler = Copy, - out = "", + out = Nothing, builder = user <> "@localhost", .. } @@ -310,10 +333,10 @@ analyze namespace@(Namespace.Namespace _ ext) = do -- Detecting a Lib is harder, and much code can be compiled by both ghc and -- ghcjs. For now I'm just guarding against known ghcjs-only modules in the -- import list. -detectGhcCompiler :: String -> String -> Compiler -detectGhcCompiler out _ | jsSuffix out = GhcjsExe -detectGhcCompiler out _ | not <| jsSuffix out || null out = GhcExe -detectGhcCompiler _ content +detectGhcCompiler :: Maybe Out -> String -> Compiler +detectGhcCompiler (Just out) _ | jsSuffix out = GhcjsExe +detectGhcCompiler (Just out) _ | not <| jsSuffix out = GhcExe +detectGhcCompiler Nothing content | match "import GHCJS" = GhcjsLib | otherwise = GhcLib where @@ -333,11 +356,10 @@ isSuccess _ = False build :: Bool -> Bool -> Target -> IO Exit.ExitCode build andTest loud Target {..} = do root <- Env.getEnv "BIZ_ROOT" + createHier root case compiler of GhcExe -> do Log.info ["bild", "dev", "ghc-exe", nschunk namespace] - let outDir = root </> "_/bild/dev/bin" - Dir.createDirectoryIfMissing True outDir exitcode <- proc loud @@ -346,22 +368,22 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path, "-main-is", Namespace.toHaskellModule namespace, "-o", - outDir </> out + root </> bindir </> Maybe.fromJust out ] if andTest && isSuccess exitcode then run <| Proc { loud = loud, - cmd = outDir </> out, + cmd = root </> bindir </> Maybe.fromJust out, args = ["test"], ns = namespace, onFailure = Log.fail ["test", nschunk namespace] >> Log.br, @@ -377,16 +399,14 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path ] GhcjsExe -> do Log.info ["bild", "dev", "ghcjs-exe", nschunk namespace] - let outDir = root </> "_/bild/dev/static" - Dir.createDirectoryIfMissing True outDir proc loud namespace @@ -394,15 +414,15 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path, "-main-is", Namespace.toHaskellModule namespace, "-o", - outDir </> out + root </> vardir </> Maybe.fromJust out ] GhcjsLib -> do Log.info ["bild", "dev", "ghcjs-lib", nschunk namespace] @@ -413,14 +433,40 @@ build andTest loud Target {..} = do [ "-Werror", "-i" <> root, "-odir", - root </> "_/bild/int", + root </> intdir, "-hidir", - root </> "_/bild/int", + root </> intdir, "--make", path ] Guile -> do - Log.warn ["bild", "guile", "TODO", nschunk namespace] + Log.info ["bild", "dev", "guile", nschunk namespace] + proc + loud + namespace + "guild" + [ "compile", + "--load-path=" ++ root, + "--output=" ++ root </> intdir </> replaceExtension path ".scm.go", + path + ] + when (isJust out) <| do + let o = Maybe.fromJust out + writeFile + (root </> bindir </> o) + <| Text.pack + <| joinWith + "\n" + [ "#!/usr/bin/env bash", + "guile -C \"" + <> root </> intdir + <> "\" -c \"(use-modules " + <> Namespace.toSchemeModule namespace + <> ") (main (command-line))\"" + <> " \"$@\"" + ] + p <- Dir.getPermissions <| root </> bindir </> o + Dir.setPermissions (root </> bindir </> o) (Dir.setOwnerExecutable True p) return Exit.ExitSuccess NixBuild -> do Log.info @@ -431,15 +477,13 @@ build andTest loud Target {..} = do else builder, nschunk namespace ] - let outDir = root </> "_/bild/nix" - Dir.createDirectoryIfMissing True outDir proc loud namespace "nix-build" [ path, "-o", - outDir </> Namespace.toPath namespace, + root </> nixdir </> Namespace.toPath namespace, "--builders", Text.unpack builder ] @@ -497,5 +541,5 @@ nschunk = Namespace.toPath .> Text.pack metaDep :: Regex.RE Char Dep metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha) -metaOut :: Regex.RE Char Out -metaOut = Regex.string "-- : out " *> Regex.many (Regex.psym (/= ' ')) +metaOut :: [Char] -> Regex.RE Char Out +metaOut comment = Regex.string (comment ++ " : out ") *> Regex.many (Regex.psym (/= ' ')) diff --git a/Biz/Bild/ShellHook.sh b/Biz/Bild/ShellHook.sh index 746f27f..c996dee 100644 --- a/Biz/Bild/ShellHook.sh +++ b/Biz/Bild/ShellHook.sh @@ -60,7 +60,7 @@ function push() { else target="$prefix.$1" fi - what=$(realpath "$BIZ_ROOT/_/bild/nix/$target") + what=$(realpath "$BIZ_ROOT/_/nix/$target") # hack: get the domain from the activation script. there does not seem # to be a way to get it from nix-instantiate where=$(rg -r '$2' -e '(domainname ")(.*)(")' "$what/activate") diff --git a/Biz/Bot.scm b/Biz/Bot.scm index c06c651..7fa5933 100755 --- a/Biz/Bot.scm +++ b/Biz/Bot.scm @@ -1,12 +1,9 @@ -#!/usr/bin/env sh -exec guile -l $BIZ_ROOT/Biz/Bot.scm -e '(@ (Biz Bot) main)' -s "$0" "$@" -!# - - +;; : out bizbot +;; ;; Usage with ii: ;; ;; tail -f \#biz/out | guile -L $BIZ_ROOT -s Biz/Bot.scm - +;; (define-module (Biz Bot) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs index 398841e..316896a 100644 --- a/Biz/Namespace.hs +++ b/Biz/Namespace.hs @@ -8,6 +8,7 @@ module Biz.Namespace fromPath, toPath, toHaskellModule, + toSchemeModule, match, ) where @@ -57,3 +58,8 @@ toPath (Namespace parts ext) = joinWith "/" parts <> "." <> lowercase (show ext) + +toSchemeModule :: Namespace -> String +toSchemeModule (Namespace parts Scm) = "(" ++ joinWith " " parts ++ ")" +toSchemeModule (Namespace _ ext) = + panic <| "can't convert " <> show ext <> " to a Scheme module" diff --git a/Biz/Serval.scm b/Biz/Serval.scm index 2ea89c2..303acdb 100644 --- a/Biz/Serval.scm +++ b/Biz/Serval.scm @@ -1,6 +1,8 @@ ;; ;; Serval - fast container management ;; +;; : out serval +;; ;; `Container management' simply refers to tracking the configuration ;; for individual containers and their running state. ;; @@ -36,11 +38,10 @@ #:select (match)) #:use-module ((srfi srfi-9) #:select (define-record-type)) - #:use-module ((Alpha Core) - #:select (second rest fmt prn first comment)) - #:use-module ((Alpha Test) + #:use-module ((bs core) + #:select (rest fmt prn comment)) + #:use-module ((bs test) #:select (testing)) - #:use-module ((Alpha Shell) #:prefix Shell.) #:export (main)) (define *data-dir* "/var/lib/serval") @@ -21,8 +21,7 @@ ) (import (rnrs base) ;; TODO: port to srfi-115 - (only (ice-9 regex) - make-regexp)) + (ice-9 regex)) ;; (define I regexp/icase) ;; (define IGNORECASE regexp/icase) diff --git a/bs/repl.scm b/bs/repl.scm index 3932433..3bf1ca1 100644 --- a/bs/repl.scm +++ b/bs/repl.scm @@ -1,4 +1,6 @@ -(define-module (bs repl)) +(define-module (bs repl) + #:use-module (system repl command)) + ;; (use-modules (system repl common)) ;; (repl-default-option-set! ;; 'prompt diff --git a/bs/test.scm b/bs/test.scm index 9152760..a45bca1 100644 --- a/bs/test.scm +++ b/bs/test.scm @@ -12,5 +12,6 @@ ;; simple analog to clojure's `testing' (define-syntax testing - ((_ description ...) - ((begin (prn description) ...)))) + (syntax-rules () + ((_ description ...) + ((begin (prn description) ...))))) |