Use wrapper and compiler fields from Target

1 files changed, 72 insertions, 46 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 75d012f..a5495f7 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -130,6 +130,7 @@ import qualified System.Environment as Env
 import qualified System.Exit as Exit
 import System.FilePath (replaceExtension, (</>))
 import qualified System.IO as IO
+import System.IO.Unsafe (unsafePerformIO)
 import qualified System.Process as Process
 import qualified Text.Regex.Applicative as Regex
 
@@ -230,16 +231,21 @@ data Compiler
   | Sbcl
   deriving (Eq, Show, Generic)
 
+compilerExe :: IsString a => Compiler -> a
+compilerExe = \case
+  Copy -> "cp"
+  Gcc -> "gcc"
+  Ghc -> "ghc"
+  Guile -> "guild"
+  NixBuild -> "nix-build"
+  Rustc -> "rustc"
+  Sbcl -> "sbcl"
+
 instance Aeson.ToJSON Compiler where
-  toJSON =
-    Aeson.String <. \case
-      Copy -> "cp"
-      Gcc -> "gcc"
-      Ghc -> "ghc"
-      Guile -> "guile"
-      NixBuild -> "nix-build"
-      Rustc -> "rustc"
-      Sbcl -> "sbcl"
+  toJSON = Aeson.String <. compilerExe
+
+instance ToNixFlag Compiler where
+  toNixFlag = compilerExe
 
 data Target = Target
   { -- | Output name
@@ -259,7 +265,9 @@ data Target = Target
     -- | Where is this machine being built?
     builder :: Builder,
     -- | Flags and arguments passed to 'Compiler' when building
-    compilerFlags :: [Text]
+    compilerFlags :: [Text],
+    -- | Wrapper script (if necessary)
+    wrapper :: Maybe Text
   }
   deriving (Show, Generic, Aeson.ToJSON)
 
@@ -274,10 +282,13 @@ instance Aeson.ToJSON Builder where
   toJSON (Local u) = Aeson.String u
   toJSON (Remote u host) = Aeson.String <| u <> "@" <> host
 
-toNixFlag :: Builder -> String
-toNixFlag = \case
-  Local _ -> ""
-  Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"]
+class ToNixFlag a where
+  toNixFlag :: a -> String
+
+instance ToNixFlag Builder where
+  toNixFlag = \case
+    Local _ -> ""
+    Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"]
 
 -- | We can't build everything yet...
 isBuildableNs :: Namespace -> Bool
@@ -306,17 +317,25 @@ isBuildableNs = \case
         ["Biz", "Dragons", "Analysis"]
       ]
 
+-- | The default output directory. This is not IO because I don't want to
+-- refactor all of my code right now, but it probably should be.
+cab :: FilePath
+cab =
+  Env.lookupEnv "CABDIR"
+    /> fromMaybe "_"
+    |> unsafePerformIO
+
 -- | Emulate the *nix hierarchy in the cabdir.
 outToPath :: Out -> FilePath
 outToPath = \case
-  Bin o -> "_/bin" </> o
-  Lib o -> "_/lib" </> o
+  Bin o -> cab </> "bin" </> o
+  Lib o -> cab </> "lib" </> o
   None -> mempty
 
-intdir, nixdir, vardir :: String
-intdir = "_/int"
-nixdir = "_/nix"
-vardir = "_/var"
+intdir, nixdir, vardir :: FilePath
+intdir = cab </> "int"
+nixdir = cab </> "nix"
+vardir = cab </> "var"
 
 createHier :: String -> IO ()
 createHier root =
@@ -380,6 +399,7 @@ analyze hmap ns = case Map.lookup ns hmap of
               +> \guileFlags ->
                 Target
                   { langdeps = Set.empty, -- c has no lang deps...?
+                    wrapper = Nothing,
                     compiler = Gcc,
                     builder = Local <| user,
                     compilerFlags =
@@ -401,6 +421,7 @@ analyze hmap ns = case Map.lookup ns hmap of
             </ pure
               Target
                 { builder = Local <| user,
+                  wrapper = Nothing,
                   compiler = Ghc,
                   compilerFlags =
                     map
@@ -435,6 +456,7 @@ analyze hmap ns = case Map.lookup ns hmap of
             </ pure
               Target
                 { sysdeps = Set.empty,
+                  wrapper = Nothing,
                   compiler = Sbcl,
                   compilerFlags =
                     map
@@ -460,6 +482,7 @@ analyze hmap ns = case Map.lookup ns hmap of
             </ pure
               Target
                 { langdeps = Set.empty,
+                  wrapper = Nothing,
                   sysdeps = Set.empty,
                   compiler = NixBuild,
                   compilerFlags =
@@ -494,6 +517,18 @@ analyze hmap ns = case Map.lookup ns hmap of
                       ],
                   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.Rs -> do
@@ -502,6 +537,7 @@ analyze hmap ns = case Map.lookup ns hmap of
             </ pure
               Target
                 { langdeps = Set.empty,
+                  wrapper = Nothing,
                   sysdeps = Set.empty,
                   compiler = Rustc,
                   compilerFlags = map Text.pack [path, "-o", root </> outToPath out],
@@ -596,7 +632,7 @@ build andTest loud analysis = do
     case compiler of
       Gcc ->
         Log.info ["bild", label, "gcc", nschunk namespace]
-          >> proc loud namespace "gcc" compilerFlags
+          >> proc loud namespace compiler compilerFlags
         where
           label = case out of
             Bin _ -> "bin"
@@ -605,36 +641,26 @@ build andTest loud analysis = do
         None -> pure Exit.ExitSuccess
         Bin _ -> do
           Log.info ["bild", "dev", "ghc-exe", nschunk namespace]
-          exitcode <- proc loud namespace "ghc" compilerFlags
+          exitcode <- proc loud namespace compiler compilerFlags
           if andTest && isSuccess exitcode
             then test loud target
             else pure exitcode
         Lib _ -> do
           Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
-          proc loud namespace "ghc" compilerFlags
+          proc loud namespace compiler compilerFlags
       Guile -> do
         Log.info ["bild", "dev", "guile", nschunk namespace]
-        _ <- proc loud namespace "guild" compilerFlags
-        (out /= None) ?| do
-          writeFile
-            (root </> outToPath out)
-            <| Text.pack
-            <| joinWith
-              "\n"
-              [ "#!/usr/bin/env bash",
-                "guile -C \""
-                  <> root </> intdir
-                  <> "\" -e main "
-                  <> "-s "
-                  <> Namespace.toPath namespace
-                  <> " \"$@\""
-              ]
-          p <- Dir.getPermissions <| root </> outToPath out
-          Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p)
-        pure Exit.ExitSuccess
+        _ <- proc loud namespace compiler compilerFlags
+        case wrapper of
+          Nothing -> pure Exit.ExitSuccess
+          Just content -> do
+            writeFile (root </> outToPath out) content
+            p <- Dir.getPermissions <| root </> outToPath out
+            Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p)
+            pure Exit.ExitSuccess
       NixBuild -> do
         Log.info ["bild", "nix", toLog builder, nschunk namespace]
-        proc loud namespace "nix-build" compilerFlags
+        proc loud namespace compiler compilerFlags
         where
           toLog (Local u) = u
           toLog (Remote u h) = u <> "@" <> h
@@ -643,10 +669,10 @@ build andTest loud analysis = do
         pure Exit.ExitSuccess
       Rustc -> do
         Log.info ["bild", "dev", "rust", nschunk namespace]
-        proc loud namespace "rustc" compilerFlags
+        proc loud namespace compiler compilerFlags
       Sbcl -> do
         Log.info ["bild", "dev", "lisp", nschunk namespace]
-        proc loud namespace "sbcl" compilerFlags
+        proc loud namespace compiler compilerFlags
 
 data Proc = Proc
   { loud :: Bool,
@@ -679,13 +705,13 @@ run Proc {..} =
         *> Async.Concurrently (Conduit.waitForStreamingProcess hdl)
 
 -- | Helper for running a standard bild subprocess.
-proc :: Bool -> Namespace -> String -> [Text] -> IO Exit.ExitCode
+proc :: ToNixFlag a => Bool -> Namespace -> a -> [Text] -> IO Exit.ExitCode
 proc loud namespace cmd args =
   run
     <| Proc
       { loud = loud,
         ns = namespace,
-        cmd = cmd,
+        cmd = toNixFlag cmd,
         args = map Text.unpack args,
         onFailure = Log.fail ["bild", nschunk namespace] >> Log.br,
         onSuccess = Log.good ["bild", nschunk namespace] >> Log.br