bild: build everyting

Now bild knows how to determine between modules that require ghcjs and ghc. It
also knows what *not* to build, meaning it won't try to build non-buildable nix
targets, for example (unfortunately this is just hardcoded for now), but it also
won't build scm or py targets that I haven't implemented yet. It just silently
fails, which is fine, because it means I can do `bild **/*` and everything just
works.

Of course, if I want to build scm code then I will have to implement that, but
that's not a priority right now.

15 files changed, 179 insertions, 111 deletions

diff --git a/.ghci b/.ghci
index 3f7039a..65154ef 100644
--- a/.ghci
+++ b/.ghci
@@ -1,6 +1,6 @@
 :set -XOverloadedStrings
-:set prompt "λ "
-:set prompt-cont "| "
+:set prompt "   λ "
+:set prompt-cont "   | "
 :set -Wall
 :set -haddock
 -- ':iq Module M' -> 'import qualified Module as M'
diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 23086a7..96f63ad 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -6,12 +6,9 @@
 
 -- | A general purpose build tool.
 --
--- Not all of the below design is implemented. Currently:
---
--- - with a nix build, results are linked in _/bild/nix/<target>
--- - with a dev build, results are stored in _/bild/dev/<target>
---
--- -----------------------------------------------------------------------------
+-- : out bild
+-- : dep docopt
+-- : dep regex-applicative
 --
 -- == Design constraints
 --
@@ -119,7 +116,7 @@
 module Biz.Bild where
 
 import Alpha hiding (sym, (<.>))
-import Biz.Namespace (Namespace)
+import Biz.Namespace (Namespace (..))
 import qualified Biz.Namespace as Namespace
 import qualified Data.Char as Char
 import qualified Data.List as List
@@ -137,8 +134,11 @@ main :: IO ()
 main = Env.getArgs >>= Docopt.parseArgsOrExit help >>= run
   where
     run args =
-      Docopt.getAllArgs args (Docopt.argument "target")
-        |> mapM_ (\target -> analyze target >>= build)
+      mapM getNamespace (Docopt.getAllArgs args (Docopt.argument "target"))
+        /> catMaybes
+        /> filter isBuildableNs
+        >>= mapM analyze
+        >>= mapM_ build
 
 help :: Docopt.Docopt
 help =
@@ -156,7 +156,14 @@ type Dep = String
 
 type Out = String
 
-data Compiler = Ghc | Ghcjs | Guile | NixBuild
+data Compiler
+  = GhcLib
+  | GhcExe
+  | GhcjsLib
+  | GhcjsExe
+  | Guile
+  | NixBuild
+  | Copy
   deriving (Show)
 
 data Target = Target
@@ -175,20 +182,42 @@ data Target = Target
   }
   deriving (Show)
 
-analyze :: String -> IO Target
-analyze s = do
-  user <- Env.getEnv "USER"
+isBuildableNs :: Namespace -> Bool
+isBuildableNs (Namespace _ Namespace.Hs) = True
+isBuildableNs ns
+  | ns `elem` nixTargets = True
+  | otherwise = False
+
+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
+  ]
+
+getNamespace :: String -> IO (Maybe Namespace)
+getNamespace s = do
   root <- Env.getEnv "BIZ_ROOT"
-  host <- chomp </ readFile "/etc/hostname"
   cwd <- Dir.getCurrentDirectory
-  let path = cwd </> s
-  let namespace@(Namespace.Namespace _ ext) =
-        require "namespace" <| Namespace.fromPath root path
+  return <| Namespace.fromPath root <| cwd </> s
+
+analyze :: Namespace -> IO Target
+analyze namespace@(Namespace.Namespace _ ext) = do
+  user <- Env.getEnv "USER"
+  host <- chomp </ readFile "/etc/hostname"
+  let path = Namespace.toPath namespace
   case ext of
     Namespace.Hs -> do
       content <- String.lines </ Prelude.readFile path
-      let out = content /> Regex.match metaOut |> catMaybes |> head |> require "out"
-      let compiler = if ".js" `List.isSuffixOf` out then Ghcjs else Ghc
+      let out =
+            content
+              /> Regex.match metaOut
+              |> catMaybes
+              |> head
+              |> fromMaybe mempty
+      let compiler = detectGhcCompiler out <| String.unlines content
       return
         Target
           { deps = content /> Regex.match metaDep |> catMaybes,
@@ -223,13 +252,41 @@ analyze s = do
             builder = user <> "@localhost",
             ..
           }
+    _ ->
+      return
+        Target
+          { deps = [],
+            compiler = Copy,
+            out = "",
+            builder = user <> "@localhost",
+            ..
+          }
+
+-- | Some rules for detecting the how to compile a ghc module. If there is an
+-- out, then we know it's some Exe; if the out ends in .js then it's GhcjsExe,
+-- otherwise GhcExe. That part is solved.
+--
+-- 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
+  | match "import GHCJS" = GhcjsLib
+  | otherwise = GhcLib
+  where
+    match s = s `List.isInfixOf` content
+
+jsSuffix :: String -> Bool
+jsSuffix = List.isSuffixOf ".js"
 
 build :: Target -> IO ()
 build target@Target {..} = do
   root <- Env.getEnv "BIZ_ROOT"
   case compiler of
-    Ghc -> do
-      putText <| "bild: dev: ghc: " <> Namespace.toPath namespace
+    GhcExe -> do
+      putStrLn <| "bild: dev: ghc-exe: " <> Namespace.toPath namespace
       let outDir = root </> "_/bild/dev/bin"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild: dev: bilder: " <> Text.pack builder
@@ -248,8 +305,22 @@ build target@Target {..} = do
           "-o",
           outDir </> out
         ]
-    Ghcjs -> do
-      putText <| "bild: dev: ghcjs: " <> Namespace.toPath namespace
+    GhcLib -> do
+      putStrLn <| "bild: dev: ghc-lib: " <> Namespace.toPath namespace
+      putText <| "bild: dev: bilder: " <> Text.pack builder
+      Process.callProcess
+        "ghc"
+        [ "-Werror",
+          "-i" <> root,
+          "-odir",
+          root </> "_/bild/int",
+          "-hidir",
+          root </> "_/bild/int",
+          "--make",
+          path
+        ]
+    GhcjsExe -> do
+      putStrLn <| "bild: dev: ghcjs-exe: " <> Namespace.toPath namespace
       let outDir = root </> "_/bild/dev/static"
       Dir.createDirectoryIfMissing True outDir
       putText <| "bild: dev: local: " <> Text.pack builder
@@ -268,13 +339,27 @@ build target@Target {..} = do
           "-o",
           outDir </> out
         ]
+    GhcjsLib -> do
+      putStrLn <| "bild: dev: ghcjs-lib: " <> Namespace.toPath namespace
+      putText <| "bild: dev: local: " <> Text.pack builder
+      Process.callProcess
+        "ghcjs"
+        [ "-Werror",
+          "-i" <> root,
+          "-odir",
+          root </> "_/bild/int",
+          "-hidir",
+          root </> "_/bild/int",
+          "--make",
+          path
+        ]
     Guile -> do
-      putText <| "bild: dev: guile: " <> Namespace.toPath namespace
+      putStrLn <| "bild: dev: guile: " <> Namespace.toPath namespace
       putText <| "bild: dev: local: " <> Text.pack builder
       putText "bild: guile TODO"
       putText <| show target
     NixBuild -> do
-      putText <| "bild: nix: " <> Namespace.toPath namespace
+      putStrLn <| "bild: nix: " <> Namespace.toPath namespace
       let outDir = root </> "_/bild/nix"
       Dir.createDirectoryIfMissing True outDir
       if null builder
@@ -284,7 +369,7 @@ build target@Target {..} = do
         "nix-build"
         [ path,
           "-o",
-          outDir </> (Text.unpack <| Namespace.toPath namespace),
+          outDir </> Namespace.toPath namespace,
           -- Set default arguments to nix functions
           "--arg",
           "bild",
@@ -300,6 +385,10 @@ build target@Target {..} = do
           "--builders",
           builder
         ]
+    Copy -> do
+      putStrLn <| "bild: copy: " <> Namespace.toPath namespace
+      putText "bild: copy TODO"
+      putText <| show target
 
 metaDep :: Regex.RE Char Dep
 metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
diff --git a/Biz/Bild/Deps/Haskell.nix b/Biz/Bild/Deps/Haskell.nix
index 001cdb2..dc33483 100644
--- a/Biz/Bild/Deps/Haskell.nix
+++ b/Biz/Bild/Deps/Haskell.nix
@@ -3,6 +3,7 @@ with hpkgs;
 [
   MonadRandom
   QuickCheck
+  SafeSemaphore
   acid-state
   aeson
   async
diff --git a/Biz/Bild/Rules.nix b/Biz/Bild/Rules.nix
index 9a7ad77..be9fa31 100644
--- a/Biz/Bild/Rules.nix
+++ b/Biz/Bild/Rules.nix
@@ -77,7 +77,7 @@ in rec {
   ghcjs = main:
     let
       data = analyze main;
-      ghcjs = mkGhcjsPackageSet (hp: selectAttrs data.dep hp);
+      ghcjs = mkGhcjsPackageSet (hp: selectAttrs data.deps hp);
     in stdenv.mkDerivation {
       name = data.module;
       src = ../../.;
@@ -105,18 +105,18 @@ in rec {
       # haskell deps
       (mkGhcPackageSet haskellDeps)
       # ghcjs doesn't need everything, and many things fail to build
-      (mkGhcjsPackageSet [
-        "aeson"
-        "clay"
-        "containers"
-        "miso"
-        "protolude"
-        "servant"
-        "split"
-        "string-quote"
-        "text"
-        "ghcjs-base"
-      ])
+      (mkGhcjsPackageSet (hp: with hp; [
+        aeson
+        clay
+        containers
+        miso
+        protolude
+        servant
+        split
+        string-quote
+        text
+        ghcjs-base
+      ]))
 
       # scheme deps
       nixpkgs.guile
diff --git a/Biz/Bild/ShellHook.sh b/Biz/Bild/ShellHook.sh
index e83973e..e307e04 100644
--- a/Biz/Bild/ShellHook.sh
+++ b/Biz/Bild/ShellHook.sh
@@ -7,7 +7,6 @@ function help() {
   echo "   deps   manage dependencies with niv"
   echo "   ghci   start ghci with correct options"
   echo "   help   show this message"
-  echo "   hero   compile and start a dev server for herocomics.app"
   echo "   lint   auto-lint all changed files"
   echo "   pie    product improvement engine"
   echo "   push   send a namespace to the cloud"
@@ -34,28 +33,6 @@ function deps() {
 
 alias ghci="ghci -i$BIZ_ROOT -ghci-script $BIZ_ROOT/.ghci"
 
-function hero() {
-  export HERO_PORT=3000
-  export HERO_KEEP=$BIZ_ROOT/_/keep
-  export HERO_SKEY=$BIZ_ROOT/_/skey
-  bild="runghc Biz.Bild"
-  if [[ ! -z "${IN_NIX_SHELL}" ]]
-  then
-    out="_/bild/dev"
-    # in dev mode, mmc.js is a directory of js assets
-    export HERO_NODE=$BIZ_ROOT/$out/static/mmc.js
-    rg --files \
-      | entr -rcs \
-        "$bild Hero.Host.hs && $bild Hero.Node.hs && $out/bin/mmc"
-  else
-    out="_/bild/nix"
-    export HERO_NODE=$BIZ_ROOT/$out/Hero.Node/static
-    rg --files \
-      | entr -rcs \
-        "$bild Hero.Host && $bild Hero.Node && $out/Hero.Host/bin/mmc"
-  fi
-}
-
 alias lint=$BIZ_ROOT/Biz/Lint.py
 
 function pie() {
@@ -73,6 +50,7 @@ function push() {
   else
     target="$prefix.$1"
   fi
+  echo "push: $target"
   what=$(realpath "$BIZ_ROOT/_/bild/nix/$target")
   # hack: get the domain from the activation script. there does not seem
   # to be a way to get it from nix-instantiate
@@ -84,21 +62,18 @@ function push() {
 
 # TODO: convert to haskell
 function ship() {
-  $BIZ_ROOT/Biz/Lint.py
-  stuff=(${1})
+  lint
+  stuff=(${@})
   if [[ ${#stuff[@]} -eq 0 ]]
   then
     stuff=(
-      Biz.Cloud
-      Biz.Dev
-      Que.Prod
-      Hero.Prod
+      Biz/Cloud.nix
+      Biz/Dev.nix
+      Biz/Que/Prod.nix
+      Hero/Prod.nix
     )
   fi
-  for thing in ${stuff[@]}
-  do
-    bild $thing
-  done
+  bild ${stuff[@]}
   for thing in ${stuff[@]}
   do
     push $thing
@@ -106,27 +81,11 @@ function ship() {
 }
 
 # Poor man's ci
-function ci() {
-  set -e
-  lint **/*
-  stuff=(
-    Biz/Pie.hs
-    Biz/Pie.nix
-    Biz/Devalloc.hs
-    Biz/Que/Site.hs
-    Biz/Que/Host.hs
-    Biz/Que/Prod.nix
-    Biz/Cloud.nix
-    Biz/Dev.nix
-    Hero/Host.hs
-    Hero/Node.hs
-    Hero/Prod.nix
-  )
-  for thing in ${stuff[@]}
-  do
-    bild "$thing"
-  done
-  set +e
+function run-ci() {
+  lint **/* && bild **/*
 }
+alias ci="time run-ci"
+
+export PS1='\n$(printf "%3.*s" $? $?)> '
 
 help
diff --git a/Biz/Cloud/Git.nix b/Biz/Cloud/Git.nix
index 6104ced..82761ce 100644
--- a/Biz/Cloud/Git.nix
+++ b/Biz/Cloud/Git.nix
@@ -11,7 +11,7 @@
       extraGitoliteRc = ''
         $RC{SITE_INFO} = 'a computer is a bicycle for the mind.';
       '';
-      adminPubkey = builtins.readFile ../Keys/Ben.pub;
+      adminPubkey = builtins.readFile ../Keys/Ben.key;
     };
   };
 }
diff --git a/Biz/Dev/Configuration.nix b/Biz/Dev/Configuration.nix
index 13be1be..0986131 100644
--- a/Biz/Dev/Configuration.nix
+++ b/Biz/Dev/Configuration.nix
@@ -247,7 +247,7 @@ in {
     sshServe = {
       enable = true;
       keys = [
-        (builtins.readFile ../Keys/Ben.pub)
+        (builtins.readFile ../Keys/Ben.key)
       ];
     };
     trustedUsers = [ "root" "ben" ];
diff --git a/Biz/Keys/Ben.pub b/Biz/Keys/Ben.key
index c661508..c661508 100644
--- a/Biz/Keys/Ben.pub
+++ b/Biz/Keys/Ben.key
diff --git a/Biz/Keys/Deploy.pub b/Biz/Keys/Deploy.key
index 664a2d9..664a2d9 100644
--- a/Biz/Keys/Deploy.pub
+++ b/Biz/Keys/Deploy.key
diff --git a/Biz/Keys/Nick.pub b/Biz/Keys/Nick.key
index 4dc08fb..4dc08fb 100644
--- a/Biz/Keys/Nick.pub
+++ b/Biz/Keys/Nick.key
diff --git a/Biz/Lint.py b/Biz/Lint.py
index fc035cb..c3e51df 100755
--- a/Biz/Lint.py
+++ b/Biz/Lint.py
@@ -89,12 +89,20 @@ if __name__ == "__main__":
     else:
         FILES = group_files(sys.argv[1:], [".hs", ".py"])
     for hs in FILES[".hs"]:
+        if not os.path.exists(hs):
+            print("lint: does not exist:", hs)
+            continue
         print(f"lint: {hs}")
         run("ormolu", hs)
         run("hlint", hs)
     for py in FILES[".py"]:
+        if not os.path.exists(py):
+            print("lint: does not exist:", py)
+            continue
         print(f"lint: {py}")
         # Broken in our nixpkgs
         # run("black", py)
         run("pylint", py)
+    if ERRORS:
+        print("lint: errors:", ERRORS)
     sys.exit(ERRORS)
diff --git a/Biz/Namespace.hs b/Biz/Namespace.hs
index 48ae1e6..574a2fc 100644
--- a/Biz/Namespace.hs
+++ b/Biz/Namespace.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
+-- : dep regex-applicative
 module Biz.Namespace
   ( Namespace (..),
     Ext (..),
@@ -14,26 +15,31 @@ where
 import Alpha
 import qualified Data.Char as Char
 import qualified Data.List as List
-import qualified Data.Text as Text
 import qualified Text.Regex.Applicative as Regex
 
-data Ext = Hs | Scm | Nix
-  deriving (Show)
+data Ext = Hs | Scm | Nix | Md | Css | Py | Sh | Key | Json | None
+  deriving (Eq, Show)
 
 data Namespace = Namespace [String] Ext
-  deriving (Show)
+  deriving (Eq, Show)
 
 match :: String -> Maybe Namespace
 match = Regex.match <| Namespace </ path <* Regex.sym '.' <*> ext
   where
     name =
       Regex.many (Regex.psym Char.isUpper)
-        <> Regex.many (Regex.psym Char.isLower)
+        <> Regex.many (Regex.psym Char.isAlphaNum)
     path = Regex.many (name <* Regex.string "/" <|> name)
     ext =
       Nix <$ Regex.string "nix"
         <|> Hs <$ Regex.string "hs"
         <|> Scm <$ Regex.string "scm"
+        <|> Md <$ Regex.string "md"
+        <|> Css <$ Regex.string "css"
+        <|> Py <$ Regex.string "py"
+        <|> Sh <$ Regex.string "sh"
+        <|> Key <$ Regex.string "key"
+        <|> Json <$ Regex.string "json"
 
 fromPath :: String -> String -> Maybe Namespace
 fromPath bizRoot absPath =
@@ -46,9 +52,8 @@ toHaskellModule (Namespace parts Hs) = joinWith "." parts
 toHaskellModule (Namespace _ ext) =
   panic <| "can't convert " <> show ext <> " to a Haskell module"
 
-toPath :: Namespace -> Text
+toPath :: Namespace -> FilePath
 toPath (Namespace parts ext) =
-  Text.pack
-    <| joinWith "/" parts
+  joinWith "/" parts
     <> "."
     <> lowercase (show ext)
diff --git a/Biz/Users.nix b/Biz/Users.nix
index 8a804ca..0f68b50 100644
--- a/Biz/Users.nix
+++ b/Biz/Users.nix
@@ -14,20 +14,20 @@
     deploy = {
       isNormalUser = true;
       home = "/home/deploy";
-      openssh.authorizedKeys.keyFiles = [ ./Keys/Deploy.pub ];
+      openssh.authorizedKeys.keyFiles = [ ./Keys/Deploy.key ];
       extraGroups = [ "wheel" ];
     };
     #
     # humans
     #
-    root.openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.pub ];
+    root.openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.key ];
     root.password = "erewhon";
 
     ben = {
       description = "Ben Sima";
       isNormalUser = true;
       home = "/home/ben";
-      openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.pub ];
+      openssh.authorizedKeys.keyFiles = [ ./Keys/Ben.key ];
       extraGroups = [ "wheel" "docker" ];
       hashedPassword =
         "$6$SGhdoRB6DhWe$elW8RQE1ebe8JKf1ALW8jGZTPCyn2rpq/0J8MV/A9y8qFMEhA.Z2eiexMgptohZAK5kcGOc6HIUgNzJqnDUvY.";
@@ -36,7 +36,7 @@
       description = "Nick Sima";
       isNormalUser = true;
       home = "/home/nick";
-      openssh.authorizedKeys.keyFiles = [ ./Keys/Nick.pub ];
+      openssh.authorizedKeys.keyFiles = [ ./Keys/Nick.key ];
       extraGroups = [ "docker" ];
     };
   };
diff --git a/Control/Concurrent/Sema.hs b/Control/Concurrent/Sema.hs
index c105cf8..202aa65 100644
--- a/Control/Concurrent/Sema.hs
+++ b/Control/Concurrent/Sema.hs
@@ -1,8 +1,11 @@
+-- : dep SafeSemaphore
 module Control.Concurrent.Sema
   ( mapPool,
   )
 where
 
+import Alpha
+import Control.Concurrent.Async (mapConcurrently)
 import qualified Control.Concurrent.MSem as Sem
 
 -- | Simaphore-based throttled 'mapConcurrently'.
diff --git a/System/Random/Shuffle.hs b/System/Random/Shuffle.hs
index d26361f..435f083 100644
--- a/System/Random/Shuffle.hs
+++ b/System/Random/Shuffle.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 
 -- |
@@ -24,6 +26,7 @@ module System.Random.Shuffle
   )
 where
 
+import Alpha
 import Control.Monad
   ( liftM2,
   )
@@ -70,7 +73,7 @@ shuffle elements = shuffleTree (buildTree elements)
     shuffleTree (Leaf e) [] = [e]
     shuffleTree tree (r : rs) =
       let (b, rest) = extractTree r tree in b : shuffleTree rest rs
-    shuffleTree _ _ = error "[shuffle] called with lists of different lengths"
+    shuffleTree _ _ = panic "[shuffle] called with lists of different lengths"
     -- Extracts the n-th element from the tree and returns
     -- that element, paired with a tree with the element
     -- deleted.
@@ -86,7 +89,7 @@ shuffle elements = shuffleTree (buildTree elements)
         let (e, l') = extractTree n l in (e, Node (c - 1) l' r)
       | otherwise =
         let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r')
-    extractTree _ _ = error "[extractTree] impossible"
+    extractTree _ _ = panic "[extractTree] impossible"
 
 -- | Given a sequence (e1,...en) to shuffle, its length, and a random
 --  generator, compute the corresponding permutation of the input