Fold analyses with a caching container

1 files changed, 224 insertions, 217 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index f23d04a..127b6a7 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -113,7 +113,7 @@ import Data.Conduit ((.|))
 import qualified Data.Conduit as Conduit
 import qualified Data.Conduit.List as Conduit
 import qualified Data.Conduit.Process as Conduit
-import qualified Data.Maybe as Maybe
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.String as String
 import qualified Data.Text as Text
@@ -133,11 +133,11 @@ main = Cli.main <| Cli.Plan help move test_ pure
       Test.group
         "Biz.Bild"
         [ Test.unit "can bild bild" <| do
-            analyze "Biz/Bild.hs"
-              /> Maybe.fromJust
-              +> build False False
+            analyze mempty "Biz/Bild.hs"
+              /> Map.elems
+              +> traverse (build False False)
               +> \case
-                Exit.ExitFailure _ ->
+                [Exit.ExitFailure _] ->
                   Test.assertFailure "can't bild bild"
                 _ ->
                   pure ()
@@ -149,10 +149,9 @@ move args =
     >> pure (Cli.getAllArgs args (Cli.argument "target"))
     /> filter (not <. Namespace.isCab)
     +> filterM Dir.doesFileExist
-    +> traverse analyze
-    /> filter isJust
-    /> map Maybe.fromJust
-    /> filter (namespace .> isBuildableNs)
+    +> foldM analyze mempty
+    /> Map.filter (namespace .> isBuildableNs)
+    /> Map.elems
     +> printOrBuild
     +> exitSummary
   where
@@ -303,217 +302,225 @@ removeVersion = takeWhile (/= '.') .> butlast2
   where
     butlast2 s = take (length s - 2) s
 
+type Analysis = Map FilePath Target
+
 -- | TODO: globally cache analyses, so I'm not re-analyzing modules all the
 -- time. This is important as it would speed up building by a lot.
-analyze :: FilePath -> IO (Maybe Target)
-analyze path = do
-  content <-
-    withFile path ReadMode <| \h ->
-      IO.hSetEncoding h IO.utf8_bom
-        >> Text.IO.hGetContents h
-  let contentLines = Text.lines content
-  root <- Env.getEnv "BIZ_ROOT"
-  absPath <- Dir.makeAbsolute path
-  user <- Env.getEnv "USER" /> Text.pack
-  host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME"
-  Log.info ["bild", "analyze", str path]
-  case Namespace.fromPath root absPath of
-    Nothing ->
-      Log.warn ["bild", "analyze", str path, "could not find namespace"]
-        >> Log.br
-        >> pure Nothing
-    Just namespace@(Namespace _ ext) -> case ext of
-      -- basically we don't support building these
-      Namespace.Css -> pure Nothing
-      Namespace.Json -> pure Nothing
-      Namespace.Keys -> pure Nothing
-      Namespace.Md -> pure Nothing
-      Namespace.None -> pure Nothing
-      Namespace.Py -> pure Nothing
-      Namespace.Sh -> pure Nothing
-      Namespace.C -> do
-        let out =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaOut "//" <|> metaLib "//")
-                |> catMaybes
-                |> head
-                |> fromMaybe None
-        let sysdeps =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaSys "//")
-                |> catMaybes
-                |> Set.fromList
-        guileFlags <-
-          if "guile_3_0" `elem` sysdeps
-            then
-              Process.readProcess "guile-config" ["compile"] ""
-                /> String.words
-                /> (++ ["-shared", "-fPIC"])
-                /> map Text.pack
-            else pure mempty
-        Just
-          </ pure
-            Target
-              { langdeps = Set.empty, -- c has no lang deps...?
-                compiler = Gcc,
-                builder = user <> "@localhost",
-                compilerFlags =
-                  concat
-                    [ [o, dir, Text.pack absPath] ++ guileFlags
-                      | let outable = out /= None,
-                        o <- outable ?: (["-o"], []),
-                        dir <- outable ?: ([Text.pack <| root </> outdir out], [])
-                    ],
-                ..
-              }
-      Namespace.Hs -> do
-        langdeps <- detectHaskellImports contentLines
-        let out =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaOut "--")
-                |> catMaybes
-                |> head
-                |> fromMaybe None
-        Just
-          </ pure
-            Target
-              { builder = user <> "@localhost",
-                compiler = detectGhcCompiler out,
-                compilerFlags =
-                  map
-                    Text.pack
-                    [ "-Werror",
-                      "-i" <> root,
-                      "-odir",
-                      root </> intdir,
-                      "-hidir",
-                      root </> intdir,
-                      "--make",
-                      path
-                    ]
-                    ++ (out /= None)
-                    ?: ( map
-                           Text.pack
-                           [ "-main-is",
-                             Namespace.toHaskellModule namespace,
-                             "-o",
-                             root </> outdir out
-                           ],
-                         []
-                       ),
-                sysdeps =
+analyze :: Analysis -> FilePath -> IO Analysis
+analyze hmap path_ = case Map.lookup path_ hmap of
+  Nothing -> do
+    mTarget <- analyze' path_
+    pure <| maybe hmap (\t -> Map.insert path_ t hmap) mTarget
+  Just _ -> pure hmap
+  where
+    analyze' :: FilePath -> IO (Maybe Target)
+    analyze' path = do
+      content <-
+        withFile path ReadMode <| \h ->
+          IO.hSetEncoding h IO.utf8_bom
+            >> Text.IO.hGetContents h
+      let contentLines = Text.lines content
+      root <- Env.getEnv "BIZ_ROOT"
+      absPath <- Dir.makeAbsolute path
+      user <- Env.getEnv "USER" /> Text.pack
+      host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME"
+      Log.info ["bild", "analyze", str path]
+      case Namespace.fromPath root absPath of
+        Nothing ->
+          Log.warn ["bild", "analyze", str path, "could not find namespace"]
+            >> Log.br
+            >> pure Nothing
+        Just namespace@(Namespace _ ext) -> case ext of
+          -- basically we don't support building these
+          Namespace.Css -> pure Nothing
+          Namespace.Json -> pure Nothing
+          Namespace.Keys -> pure Nothing
+          Namespace.Md -> pure Nothing
+          Namespace.None -> pure Nothing
+          Namespace.Py -> pure Nothing
+          Namespace.Sh -> pure Nothing
+          Namespace.C -> do
+            let out =
                   contentLines
                     /> Text.unpack
-                    /> Regex.match (metaSys "--")
+                    /> Regex.match (metaOut "//" <|> metaLib "//")
                     |> catMaybes
-                    |> Set.fromList,
-                ..
-              }
-      Namespace.Lisp -> do
-        let out =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaOut ";;")
-                |> catMaybes
-                |> head
-                |> fromMaybe None
-        langdeps <- detectLispImports contentLines
-        Just
-          </ pure
-            Target
-              { sysdeps = Set.empty,
-                compiler = Sbcl,
-                compilerFlags =
-                  map
-                    Text.pack
-                    [ "--load",
-                      path,
-                      "--eval",
-                      "(require :asdf)",
-                      "--eval",
-                      "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out) <> "\" :toplevel #'main :executable t)"
-                    ],
-                builder = user <> "@localhost",
-                ..
-              }
-      Namespace.Nix -> do
-        let builder =
-              (host == "lithium")
-                ?: ( "local",
-                     Text.concat
-                       [ "ssh://",
-                         user,
-                         "@dev.simatime.com?ssh-key=/home/",
-                         user,
-                         "/.ssh/id_rsa"
-                       ]
-                   )
-        Just
-          </ pure
-            Target
-              { langdeps = Set.empty,
-                sysdeps = Set.empty,
-                compiler = NixBuild,
-                compilerFlags =
-                  map
-                    Text.pack
-                    [ path,
-                      "--out-link",
-                      root </> nixdir </> Namespace.toPath namespace,
-                      "--builders",
-                      Text.unpack builder
-                    ],
-                out = None,
-                ..
-              }
-      Namespace.Scm -> do
-        let out =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaOut ";;")
-                |> catMaybes
-                |> head
-                |> fromMaybe None
-        Just
-          </ pure
-            Target
-              { langdeps = Set.empty,
-                sysdeps = Set.empty,
-                compiler = Guile,
-                compilerFlags =
-                  map
-                    Text.pack
-                    [ "compile",
-                      "--r7rs",
-                      "--load-path=" ++ root,
-                      "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
-                      path
-                    ],
-                builder = user <> "@localhost",
-                ..
-              }
-      Namespace.Rs -> do
-        let out =
-              contentLines
-                /> Text.unpack
-                /> Regex.match (metaOut "//")
-                |> catMaybes
-                |> head
-                |> fromMaybe None
-        Just
-          </ pure
-            Target
-              { langdeps = Set.empty,
-                sysdeps = Set.empty,
-                compiler = Rustc,
-                compilerFlags = map Text.pack [path, "-o", root </> outdir out],
-                builder = user <> "@localhost",
-                ..
-              }
-  where
+                    |> head
+                    |> fromMaybe None
+            let sysdeps =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaSys "//")
+                    |> catMaybes
+                    |> Set.fromList
+            guileFlags <-
+              if "guile_3_0" `elem` sysdeps
+                then
+                  Process.readProcess "guile-config" ["compile"] ""
+                    /> String.words
+                    /> (++ ["-shared", "-fPIC"])
+                    /> map Text.pack
+                else pure mempty
+            Just
+              </ pure
+                Target
+                  { langdeps = Set.empty, -- c has no lang deps...?
+                    compiler = Gcc,
+                    builder = user <> "@localhost",
+                    compilerFlags =
+                      concat
+                        [ [o, dir, Text.pack absPath] ++ guileFlags
+                          | let outable = out /= None,
+                            o <- outable ?: (["-o"], []),
+                            dir <- outable ?: ([Text.pack <| root </> outdir out], [])
+                        ],
+                    ..
+                  }
+          Namespace.Hs -> do
+            langdeps <- detectHaskellImports contentLines
+            let out =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaOut "--")
+                    |> catMaybes
+                    |> head
+                    |> fromMaybe None
+            Just
+              </ pure
+                Target
+                  { builder = user <> "@localhost",
+                    compiler = detectGhcCompiler out,
+                    compilerFlags =
+                      map
+                        Text.pack
+                        [ "-Werror",
+                          "-i" <> root,
+                          "-odir",
+                          root </> intdir,
+                          "-hidir",
+                          root </> intdir,
+                          "--make",
+                          path
+                        ]
+                        ++ (out /= None)
+                        ?: ( map
+                               Text.pack
+                               [ "-main-is",
+                                 Namespace.toHaskellModule namespace,
+                                 "-o",
+                                 root </> outdir out
+                               ],
+                             []
+                           ),
+                    sysdeps =
+                      contentLines
+                        /> Text.unpack
+                        /> Regex.match (metaSys "--")
+                        |> catMaybes
+                        |> Set.fromList,
+                    ..
+                  }
+          Namespace.Lisp -> do
+            let out =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaOut ";;")
+                    |> catMaybes
+                    |> head
+                    |> fromMaybe None
+            langdeps <- detectLispImports contentLines
+            Just
+              </ pure
+                Target
+                  { sysdeps = Set.empty,
+                    compiler = Sbcl,
+                    compilerFlags =
+                      map
+                        Text.pack
+                        [ "--load",
+                          path,
+                          "--eval",
+                          "(require :asdf)",
+                          "--eval",
+                          "(sb-ext:save-lisp-and-die #p\"" <> (root </> outdir out) <> "\" :toplevel #'main :executable t)"
+                        ],
+                    builder = user <> "@localhost",
+                    ..
+                  }
+          Namespace.Nix -> do
+            let builder =
+                  (host == "lithium")
+                    ?: ( "local",
+                         Text.concat
+                           [ "ssh://",
+                             user,
+                             "@dev.simatime.com?ssh-key=/home/",
+                             user,
+                             "/.ssh/id_rsa"
+                           ]
+                       )
+            Just
+              </ pure
+                Target
+                  { langdeps = Set.empty,
+                    sysdeps = Set.empty,
+                    compiler = NixBuild,
+                    compilerFlags =
+                      map
+                        Text.pack
+                        [ path,
+                          "--out-link",
+                          root </> nixdir </> Namespace.toPath namespace,
+                          "--builders",
+                          Text.unpack builder
+                        ],
+                    out = None,
+                    ..
+                  }
+          Namespace.Scm -> do
+            let out =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaOut ";;")
+                    |> catMaybes
+                    |> head
+                    |> fromMaybe None
+            Just
+              </ pure
+                Target
+                  { langdeps = Set.empty,
+                    sysdeps = Set.empty,
+                    compiler = Guile,
+                    compilerFlags =
+                      map
+                        Text.pack
+                        [ "compile",
+                          "--r7rs",
+                          "--load-path=" ++ root,
+                          "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
+                          path
+                        ],
+                    builder = user <> "@localhost",
+                    ..
+                  }
+          Namespace.Rs -> do
+            let out =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaOut "//")
+                    |> catMaybes
+                    |> head
+                    |> fromMaybe None
+            Just
+              </ pure
+                Target
+                  { langdeps = Set.empty,
+                    sysdeps = Set.empty,
+                    compiler = Rustc,
+                    compilerFlags = map Text.pack [path, "-o", root </> outdir out],
+                    builder = user <> "@localhost",
+                    ..
+                  }
     detectHaskellImports :: [Text] -> IO (Set Dep)
     detectHaskellImports contentLines = do
       let imports =
@@ -527,8 +534,8 @@ analyze path = do
           |> map (Namespace.fromHaskellModule .> Namespace.toPath)
           |> traverse Dir.makeAbsolute
           +> filterM Dir.doesFileExist
-          +> Async.mapConcurrently analyze
-          /> catMaybes
+          +> foldM analyze hmap
+          /> Map.elems
           /> map langdeps
           /> mconcat
       pure <| pkgs <> transitivePkgs