Get all scheme code compiling with Guile

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")
diff --git a/bs/re.scm b/bs/re.scm
index a325249..0ab442b 100644
--- a/bs/re.scm
+++ b/bs/re.scm
@@ -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) ...)))))