Factor out nix builder into Haskell.nix

This also fixed a bug where every dependency would get pulled into the Haskell
target while searching for transitive dependencies.

1 files changed, 71 insertions, 92 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 96203a4..f0b829d 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -109,7 +109,6 @@ import qualified Biz.Cli as Cli
 import qualified Biz.Log as Log
 import Biz.Namespace (Namespace (..))
 import qualified Biz.Namespace as Namespace
-import Biz.Test ((@?=))
 import qualified Biz.Test as Test
 import qualified Conduit
 import qualified Control.Concurrent.Async as Async
@@ -127,7 +126,6 @@ import qualified Data.Set as Set
 import qualified Data.String as String
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text.IO
-import qualified NeatInterpolation
 import qualified System.Directory as Dir
 import qualified System.Environment as Env
 import qualified System.Exit as Exit
@@ -156,7 +154,6 @@ main = Cli.main <| Cli.Plan help move test_ pure
                       Test.assertFailure "can't bild bild"
                     _ ->
                       pure ()
-                      -- test_toNixExpr
         ]
 
 move :: Cli.Arguments -> IO ()
@@ -266,40 +263,6 @@ data Target = Target
   }
   deriving (Show, Generic, Aeson.ToJSON)
 
-toNixExpr :: String -> Target -> Text
-toNixExpr root (Target {..}) =
-  [NeatInterpolation.trimming|
-with import $troot/Biz/Bild.nix {};
-with builtins;
-let
-  skip = ["_" ".direnv"];
-  filter = name: type:
-    if elem (baseNameOf name) skip then false
-    # TODO: this means any new directory will cause a rebuild. this bad.
-    # i should recurse into the directory and match against the srcFiles
-    else if type == "directory" then true
-    else if type == "regular" then builtins.elem name [$srcFiles]
-    else false;
-in stdenv.mkDerivation {
-  name = "$outname_";
-  src = lib.sources.cleanSourceWith {inherit filter; src = lib.sources.cleanSource ./.;};
-  buildInputs = [ (private.ghcWith (p: with p; [$nixLangdeps])) ];
-  buildPhase = "$compilerCommand $compilerArgs";
-  installPhase = "mkdir -p $$out/bin && cp $outname_ $$out/bin";
-}|]
-  where
-    troot, compilerCommand, compilerArgs, nixLangdeps, outname_, srcFiles :: Text
-    troot = Text.pack root
-    compilerCommand = compilerExe compiler
-    compilerArgs = str <| unwords compilerFlags
-    nixLangdeps = str <| String.unwords <| Set.toList langdeps
-    outname_ = str <| outname out
-    srcFiles =
-      ((root </> path) : Set.toList srcs)
-        |> map (\p -> "\"" <> p <> "\"\n")
-        |> String.unwords
-        |> str
-
 -- | Use this to just get a target to play with at the repl.
 dev_getTarget :: IO Target
 dev_getTarget = do
@@ -315,16 +278,6 @@ dev_getTarget = do
             Nothing -> panic "Could not retrieve target from analysis"
             Just t -> t
 
-test_toNixExpr :: Test.Tree
-test_toNixExpr =
-  Test.group
-    "toNixExpr"
-    [ Test.unit "produces corect result" <| do
-        root <- Env.getEnv "BIZ_ROOT"
-        t <- dev_getTarget
-        toNixExpr root t @?= [NeatInterpolation.trimming|TODO|]
-    ]
-
 data Builder
   = -- | Local <user>
     Local Text
@@ -489,37 +442,39 @@ analyze hmap ns = case Map.lookup ns hmap of
               |> Just
               |> pure
         Namespace.Hs ->
-          Meta.detectOut (Meta.out "--") contentLines |> \out -> do
-            (langdeps, srcs) <- detectHaskellImports hmap contentLines
-            Target
-              { builder = Local user,
-                wrapper = Nothing,
-                compiler = Ghc,
-                compilerFlags =
-                  [ "-Werror",
-                    "-i$src",
-                    "-odir",
-                    ".",
-                    "-hidir",
-                    ".",
-                    "--make",
-                    "$src" </> path
-                  ]
-                    ++ case out of
-                      Meta.Bin o ->
-                        [ "-main-is",
-                          Namespace.toHaskellModule namespace,
-                          "-o",
-                          o
-                        ]
-                      _ -> []
-                    |> map Text.pack,
-                sysdeps = Meta.detect (Meta.sys "--") contentLines,
-                outPath = outToPath out,
-                ..
-              }
-              |> Just
-              |> pure
+          contentLines
+            |> Meta.detectOut (Meta.out "--")
+            |> \out ->
+              detectHaskellImports hmap contentLines +> \(langdeps, srcs) ->
+                Target
+                  { builder = Local user,
+                    wrapper = Nothing,
+                    compiler = Ghc,
+                    compilerFlags =
+                      [ "-Werror",
+                        "-i$src",
+                        "-odir",
+                        ".",
+                        "-hidir",
+                        ".",
+                        "--make",
+                        "$src" </> path
+                      ]
+                        ++ case out of
+                          Meta.Bin o ->
+                            [ "-main-is",
+                              Namespace.toHaskellModule namespace,
+                              "-o",
+                              o
+                            ]
+                          _ -> []
+                        |> map Text.pack,
+                    sysdeps = Meta.detect (Meta.sys "--") contentLines,
+                    outPath = outToPath out,
+                    ..
+                  }
+                  |> Just
+                  |> pure
         Namespace.Lisp ->
           Meta.detectOut (Meta.out ";;") contentLines |> \out -> do
             langdeps <- detectLispImports contentLines
@@ -628,10 +583,13 @@ detectHaskellImports hmap contentLines =
       |> catMaybes
       |> \imports ->
         foldM ghcPkgFindModule Set.empty imports
-          +> \pkgs -> do
-            a <- filepaths imports
-            b <- deps root imports
-            pure (b <> pkgs, Set.fromList a)
+          +> \pkgs ->
+            filepaths imports
+              +> \files ->
+                findDeps root files
+                  +> \deps ->
+                    (pkgs <> deps, Set.fromList files)
+                      |> pure
   where
     filepaths :: [String] -> IO [FilePath]
     filepaths imports =
@@ -640,20 +598,22 @@ detectHaskellImports hmap contentLines =
         |> map Namespace.toPath
         |> traverse Dir.makeAbsolute
         +> filterM Dir.doesFileExist
-    deps :: String -> [String] -> IO (Set Meta.Dep)
-    deps root imports =
-      filepaths imports
-        +> traverse (pure <. Namespace.fromPath root)
+    findDeps :: String -> [FilePath] -> IO (Set Meta.Dep)
+    findDeps root fps =
+      fps
+        |> traverse (pure <. Namespace.fromPath root)
         /> catMaybes
         -- this is still an inefficiency, because this recurses before the
         -- hmap is updated by the fold, transitive imports will be
         -- re-visited. you can see this with `TERM=dumb bild`. to fix this i
         -- need shared state instead of a fold, or figure out how to do a
         -- breadth-first search instead of depth-first.
-        +> foldM analyze hmap
+        +> foldM analyze (onlyHaskell hmap)
         /> Map.elems
         /> map langdeps
         /> mconcat
+    onlyHaskell :: Analysis -> Analysis
+    onlyHaskell = Map.filterWithKey (\ns _ -> ext ns == Namespace.Hs)
 
 detectLispImports :: [Text] -> IO (Set Meta.Dep)
 detectLispImports contentLines =
@@ -761,7 +721,8 @@ data Proc = Proc
 
 -- | Run a subprocess, streaming output if --loud is set.
 run :: Proc -> IO (Exit.ExitCode, ByteString)
-run Proc {..} =
+run Proc {..} = do
+  loud ?| Log.info ["proc", unwords <| map str <| cmd : args] >> Log.br
   Conduit.proc cmd args
     |> Conduit.streamingProcess
     +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) ->
@@ -769,8 +730,6 @@ run Proc {..} =
         +> \output ->
           Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_))
             *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_))
-            *> Async.Concurrently (putsToTmp stdout_ "/tmp/bild-log.out")
-            *> Async.Concurrently (putsToTmp stderr_ "/tmp/bild-log.err")
             *> Async.Concurrently (Conduit.waitForStreamingProcess hdl)
             |> Async.runConcurrently
             +> \case
@@ -848,7 +807,7 @@ lispRequires =
     isQuote c = c `elem` ['\'', ':']
 
 nixBuild :: Bool -> Target -> IO (Exit.ExitCode, ByteString)
-nixBuild loud target@(Target {..}) =
+nixBuild loud Target {..} =
   Env.getEnv "BIZ_ROOT" +> \root ->
     instantiate root |> run +> \case
       (Exit.ExitSuccess, drv) ->
@@ -861,12 +820,32 @@ nixBuild loud target@(Target {..}) =
           >> run symlink
       x -> pure x
   where
+    argstr :: Text -> Text -> [Text]
+    argstr n v = ["--argstr", n, v]
     instantiate root =
       Proc
         { loud = loud,
           ns = namespace,
           cmd = "nix-instantiate",
-          args = map Text.unpack ["--expr", toNixExpr root target],
+          -- Getting the args quoted correctly is harder than it should be. This
+          -- is tightly coupled with the code in the nix builder and there's no
+          -- way around that, methinks.
+          args =
+            [ argstr "srcs" <| unwords <| map str <| (root </> path) : Set.toList srcs,
+              argstr "root" <| str root,
+              argstr "packageSet" "ghcWith"
+            ]
+              ++ (langdeps == mempty)
+              ?: ( [],
+                   [argstr "langDeps" <| unwords <| map str <| Set.toList langdeps]
+                 )
+              ++ [ argstr "name" <| str <| outname out,
+                   argstr "main" <| str path,
+                   argstr "mainIs" <| str <| Namespace.toHaskellModule namespace,
+                   [str <| root </> "Biz/Bild/Haskell.nix"]
+                 ]
+              |> mconcat
+              |> map Text.unpack,
           onFailure = Log.fail ["bild", "instantiate", nschunk namespace] >> Log.br,
           onSuccess = pure ()
         }