Key analyses on Namespace, not FilePath

Namespace is unique, whereas FilePath could be relative or absolute, or have a
leading . or trailing / or not.

1 files changed, 215 insertions, 207 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 127b6a7..06c102f 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -133,7 +133,9 @@ main = Cli.main <| Cli.Plan help move test_ pure
       Test.group
         "Biz.Bild"
         [ Test.unit "can bild bild" <| do
-            analyze mempty "Biz/Bild.hs"
+            root <- Env.getEnv "BIZ_ROOT"
+            let Just ns = Namespace.fromPath root "Biz/Bild.hs"
+            analyze mempty ns
               /> Map.elems
               +> traverse (build False False)
               +> \case
@@ -144,11 +146,15 @@ main = Cli.main <| Cli.Plan help move test_ pure
         ]
 
 move :: Cli.Arguments -> IO ()
-move args =
+move args = do
+  root <- Env.getEnv "BIZ_ROOT"
   IO.hSetBuffering stdout IO.NoBuffering
     >> pure (Cli.getAllArgs args (Cli.argument "target"))
     /> filter (not <. Namespace.isCab)
     +> filterM Dir.doesFileExist
+    +> traverse Dir.makeAbsolute
+    /> map (Namespace.fromPath root)
+    /> catMaybes
     +> foldM analyze mempty
     /> Map.filter (namespace .> isBuildableNs)
     /> Map.elems
@@ -302,19 +308,18 @@ removeVersion = takeWhile (/= '.') .> butlast2
   where
     butlast2 s = take (length s - 2) s
 
-type Analysis = Map FilePath Target
+type Analysis = Map Namespace 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 :: Analysis -> FilePath -> IO Analysis
-analyze hmap path_ = case Map.lookup path_ hmap of
+analyze :: Analysis -> Namespace -> IO Analysis
+analyze hmap ns = case Map.lookup ns hmap of
   Nothing -> do
-    mTarget <- analyze' path_
-    pure <| maybe hmap (\t -> Map.insert path_ t hmap) mTarget
+    mTarget <- analyzeOne ns
+    pure <| maybe hmap (\t -> Map.insert ns t hmap) mTarget
   Just _ -> pure hmap
   where
-    analyze' :: FilePath -> IO (Maybe Target)
-    analyze' path = do
+    analyzeOne :: Namespace -> IO (Maybe Target)
+    analyzeOne namespace@(Namespace _ ext) = do
+      let path = Namespace.toPath namespace
       content <-
         withFile path ReadMode <| \h ->
           IO.hSetEncoding h IO.utf8_bom
@@ -325,202 +330,197 @@ analyze hmap path_ = case Map.lookup path_ hmap of
       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 =
-                      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",
-                    ..
-                  }
+      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 =
+                    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 =
@@ -529,11 +529,19 @@ analyze hmap path_ = case Map.lookup path_ hmap of
               /> Regex.match haskellImports
               |> catMaybes
       pkgs <- foldM ghcPkgFindModule Set.empty imports
+      root <- Env.getEnv "BIZ_ROOT"
       transitivePkgs <-
         imports
           |> map (Namespace.fromHaskellModule .> Namespace.toPath)
           |> traverse Dir.makeAbsolute
           +> filterM Dir.doesFileExist
+          /> map (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
           /> Map.elems
           /> map langdeps