From 330e4363d8abb509031d2c8c1a89dcc6f955e2c1 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Fri, 4 Dec 2020 11:16:25 -0500
Subject: Renamespace Devalloc and Que

Move them under the Biz root so that we know they are specific to Biz stuff. Biz
is for proprietary stuff that we own.

I also had to refactor the bild namespace parsing code because it couldn't
handle a namespace with 3 parts. I really need to get that namespace library
written and tested.
---
 Biz/Bild.hs | 81 +++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 49 insertions(+), 32 deletions(-)

(limited to 'Biz/Bild.hs')

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 2526395..81ab44f 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -133,13 +133,17 @@ main =
     Nothing -> Exit.die "usage: bild <target>"
     Just target -> analyze target >>= build
 
-type Namespace = String
+data Ext = Hs | Scm | Nix
+  deriving (Show)
+
+data Namespace = Namespace [String] Ext
+  deriving (Show)
 
 type Dep = String
 
 type Out = String
 
-data Compiler = Ghc | Ghcjs | Guile | Nix
+data Compiler = Ghc | Ghcjs | Guile | NixBuild
   deriving (Show)
 
 data Target = Target
@@ -164,6 +168,12 @@ analyze s = do
   root <- Env.getEnv "BIZ_ROOT"
   cwd <- Dir.getCurrentDirectory
   let path = cwd </> s
+      namespace =
+        require "namespace"
+          <| path
+          |> reps root ""
+          |> List.stripPrefix "/"
+          >>= Regex.match metaNamespace
   case File.takeExtension path of
     ".hs" -> do
       content <- String.lines </ Prelude.readFile path
@@ -171,25 +181,15 @@ analyze s = do
       let compiler = if ".js" `List.isSuffixOf` out then Ghcjs else Ghc
       return
         Target
-          { namespace =
-              require "namespace"
-                <| path
-                |> reps root ""
-                |> File.dropExtension
-                |> reps "/" "."
-                |> List.stripPrefix "."
-                >>= Regex.match metaNamespace,
-            deps = content /> Regex.match metaDep |> catMaybes,
+          { deps = content /> Regex.match metaDep |> catMaybes,
             builder = user <> "@localhost",
             ..
           }
     ".nix" ->
       return
         Target
-          { namespace = reps root "" path |> List.stripPrefix "/" |> require "namespace",
-            path = path,
-            deps = [],
-            compiler = Nix,
+          { deps = [],
+            compiler = NixBuild,
             out = "",
             builder =
               join
@@ -198,17 +198,17 @@ analyze s = do
                   "@dev.simatime.com?ssh-key=/home/",
                   user,
                   "/.ssh/id_rsa"
-                ]
+                ],
+            ..
           }
     ".scm" ->
       return
         Target
-          { namespace = reps root "" path |> List.stripPrefix "/" |> require "namespace",
-            path = path,
-            deps = [],
+          { deps = [],
             compiler = Guile,
             out = "",
-            builder = user <> "@localhost"
+            builder = user <> "@localhost",
+            ..
           }
     e -> panic <| "bild does not know this extension: " <> Text.pack e
 
@@ -217,7 +217,7 @@ build target@Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
     Ghc -> do
-      putText <| "bild: dev: ghc: " <> Text.pack namespace
+      putText <| "bild: dev: ghc: " <> nsToPath namespace
       let outDir = root </> "_/bild/dev/bin"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild: dev: local: " <> Text.pack builder
@@ -232,12 +232,12 @@ build target@Target {..} = do
           "--make",
           path,
           "-main-is",
-          namespace,
+          nsToHaskellModule namespace,
           "-o",
           outDir </> out
         ]
     Ghcjs -> do
-      putText <| "bild: dev: ghcjs: " <> Text.pack namespace
+      putText <| "bild: dev: ghcjs: " <> nsToPath namespace
       let outDir = root </> "_/bild/dev/static"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild: dev: local: " <> Text.pack builder
@@ -252,19 +252,17 @@ build target@Target {..} = do
           "--make",
           path,
           "-main-is",
-          namespace,
+          nsToHaskellModule namespace,
           "-o",
           outDir </> out
         ]
     Guile -> do
-      putText <| "bild: dev: guile: " <> Text.pack namespace
-      let outDir = root </> "_/bild/dev/bin"
-      Dir.createDirectoryIfMissing True outDir
+      putText <| "bild: dev: guile: " <> nsToPath namespace
       putText <| "bild: dev: local: " <> Text.pack builder
       putText "bild: guile TODO"
       putText <| show target
-    Nix -> do
-      putText <| "bild: nix: " <> Text.pack namespace
+    NixBuild -> do
+      putText <| "bild: nix: " <> nsToPath namespace
       let outDir = root </> "_/bild/nix"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild: nix: remote: " <> Text.pack builder
@@ -272,7 +270,7 @@ build target@Target {..} = do
         "nix-build"
         [ path,
           "-o",
-          outDir </> namespace,
+          outDir </> (Text.unpack <| nsToPath namespace),
           -- Set default arguments to nix functions
           "--arg",
           "bild",
@@ -290,10 +288,29 @@ build target@Target {..} = do
           builder
         ]
 
+nsToHaskellModule :: Namespace -> String
+nsToHaskellModule (Namespace parts Hs) = joinWith "." parts
+nsToHaskellModule (Namespace _ ext) =
+  panic <| "can't convert " <> show ext <> " to a Haskell module"
+
+nsToPath :: Namespace -> Text
+nsToPath (Namespace parts ext) =
+  Text.pack
+    <| joinWith "/" parts
+    <> "."
+    <> lowercase (show ext)
+
 metaNamespace :: Regex.RE Char Namespace
-metaNamespace = name <> Regex.many (Regex.sym '.') <> name
+metaNamespace = Namespace </ path <* Regex.sym '.' <*> ext
   where
-    name = Regex.many (Regex.psym Char.isUpper) <> Regex.many (Regex.psym Char.isLower)
+    name =
+      Regex.many (Regex.psym Char.isUpper)
+        <> Regex.many (Regex.psym Char.isLower)
+    path = Regex.many (name <* Regex.string "/" <|> name)
+    ext =
+      Nix <$ Regex.string "nix"
+        <|> Hs <$ Regex.string "hs"
+        <|> Scm <$ Regex.string "scm"
 
 metaDep :: Regex.RE Char Dep
 metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
-- 
cgit v1.2.3