Factor out metadata handling into Biz.Bild.Meta

The code was becoming repetitive and messy, with functions like 'metaDep' and so
on. So that's an indication that they just need to have their own home.

2 files changed, 298 insertions, 274 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index 35932b5..ae9244a 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -104,6 +104,7 @@
 module Biz.Bild where
 
 import Alpha hiding (sym, (<.>))
+import qualified Biz.Bild.Meta as Meta
 import qualified Biz.Cli as Cli
 import qualified Biz.Log as Log
 import Biz.Namespace (Namespace (..))
@@ -209,20 +210,6 @@ exitSummary exits =
   where
     failures = length <| filter isFailure exits
 
-type Dep = String
-
-type Arg = String
-
-data Out = Lib String | Bin String | None
-  deriving (Show, Eq)
-
-instance Aeson.ToJSON Out where
-  toJSON =
-    Aeson.String <. Text.pack <. \case
-      Bin a -> a
-      Lib a -> a
-      None -> ""
-
 data Compiler
   = Copy
   | Gcc
@@ -251,17 +238,18 @@ instance ToNixFlag Compiler where
 
 data Target = Target
   { -- | Output name
-    out :: Out,
+    out :: Meta.Out,
     -- | Output path (into cabdir)
     outPath :: FilePath,
     -- | Fully qualified namespace partitioned by '.'
     namespace :: Namespace,
     -- | Absolute path to file
     path :: FilePath,
-    -- | Language-specific dependencies
-    langdeps :: Set Dep,
-    -- | System-level dependencies
-    sysdeps :: Set Dep,
+    -- | Language-specific dependencies, required during compilation
+    langdeps :: Set Meta.Dep,
+    -- | System-level dependencies, required during runtime either via PATH or
+    -- linking, depending on the language
+    sysdeps :: Set Meta.Dep,
     -- | Which compiler should we use?
     compiler :: Compiler,
     -- | Where is this machine being built?
@@ -327,24 +315,24 @@ cab =
     /> fromMaybe "_"
     |> unsafePerformIO
 
--- | Emulate the *nix hierarchy in the cabdir.
-outToPath :: Out -> FilePath
+outToPath :: Meta.Out -> FilePath
 outToPath = \case
-  Bin o -> cab </> "bin" </> o
-  Lib o -> cab </> "lib" </> o
-  None -> mempty
+  Meta.Bin o -> cab </> "bin" </> o
+  Meta.Lib o -> cab </> "lib" </> o
+  Meta.None -> mempty
 
 intdir, nixdir, vardir :: FilePath
 intdir = cab </> "int"
 nixdir = cab </> "nix"
 vardir = cab </> "var"
 
+-- | Emulate the *nix hierarchy in the cabdir.
 createHier :: String -> IO ()
 createHier root =
   traverse_
     (Dir.createDirectoryIfMissing True)
-    [ root </> (outToPath <| Bin ""),
-      root </> (outToPath <| Lib ""),
+    [ root </> (outToPath <| Meta.Bin ""),
+      root </> (outToPath <| Meta.Lib ""),
       root </> intdir,
       root </> nixdir,
       root </> vardir
@@ -369,16 +357,17 @@ analyze hmap ns = case Map.lookup ns hmap of
     analyzeOne :: Namespace -> IO (Maybe Target)
     analyzeOne namespace@(Namespace _ ext) = do
       let path = Namespace.toPath namespace
-      content <-
+      contentLines <-
         withFile path ReadMode <| \h ->
           IO.hSetEncoding h IO.utf8_bom
             >> Text.IO.hGetContents h
-      let contentLines = Text.lines content
+            /> Text.lines
       root <- Env.getEnv "BIZ_ROOT"
       absPath <- Dir.makeAbsolute path
       user <- Env.getEnv "USER" /> Text.pack
       host <- Env.lookupEnv "HOSTNAME" /> fromMaybe "interactive" /> Text.pack
       Log.info ["bild", "analyze", str path]
+      let runw cmd args = Process.readProcess cmd args "" /> Text.pack /> Text.words
       case ext of
         -- basically we don't support building these
         Namespace.Css -> pure Nothing
@@ -388,225 +377,197 @@ analyze hmap ns = case Map.lookup ns hmap of
         Namespace.None -> pure Nothing
         Namespace.Py -> pure Nothing
         Namespace.Sh -> pure Nothing
-        Namespace.C -> do
-          let out = detectOut (metaOut "//" <|> metaLib "//") contentLines
-          let args = detectMeta (metaArg "//") contentLines
-          let langdeps = detectMeta (metaDep "//") contentLines
-          langdepFlags <-
-            if null langdeps
-              then pure []
-              else
-                Process.readProcess
-                  "pkg-config"
-                  ("--cflags" : Set.toList langdeps)
-                  ""
-                  /> Text.pack
-                  /> Text.words
-
-          let sysdeps = detectMeta (metaSys "//") contentLines
-          sysdepFlags <-
-            if null sysdeps
-              then pure []
-              else
-                Process.readProcess
-                  "pkg-config"
-                  ("--libs" : Set.toList sysdeps)
-                  ""
-                  /> Text.pack
-                  /> Text.words
-          Target
-            { langdeps = Set.empty, -- c has no lang deps...?
-              wrapper = Nothing,
-              compiler = Gcc,
-              builder = Local <| user,
-              compilerFlags =
-                concat
-                  [ [o, dir, Text.pack absPath]
-                      ++ langdepFlags
-                      ++ sysdepFlags
-                      ++ (map Text.pack <| Set.toList args)
-                    | let outable = out /= None,
-                      o <- outable ?: (["-o"], []),
-                      dir <- outable ?: ([Text.pack <| root </> outToPath out], [])
-                  ],
-              outPath = outToPath out,
-              ..
-            }
-            |> Just
-            |> pure
-        Namespace.Hs -> do
-          langdeps <- detectHaskellImports contentLines
-          let out = detectOut (metaOut "--") contentLines
-          Just
-            </ pure
-              Target
-                { builder = Local <| user,
-                  wrapper = Nothing,
-                  compiler = Ghc,
-                  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 </> outToPath out
-                             ],
-                           []
-                         ),
-                  sysdeps = detectMeta (metaSys "--") contentLines,
-                  outPath = outToPath out,
-                  ..
-                }
-        Namespace.Lisp -> do
-          let out = detectOut (metaOut ";;") contentLines
-          langdeps <- detectLispImports contentLines
-          Just
-            </ pure
-              Target
-                { sysdeps = Set.empty,
-                  wrapper = Nothing,
-                  compiler = Sbcl,
-                  compilerFlags =
-                    map
-                      Text.pack
-                      [ "--eval",
-                        "(require :asdf)",
-                        "--load",
-                        path,
-                        "--eval",
-                        "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)"
-                      ],
-                  builder = Local <| user,
-                  outPath = outToPath out,
-                  ..
-                }
-        Namespace.Nix -> do
-          let builder =
-                (host == "lithium")
-                  ?: ( Local user,
-                       Remote user "dev.simatime.com"
-                     )
-          Just
-            </ pure
-              Target
-                { langdeps = Set.empty,
-                  wrapper = Nothing,
-                  sysdeps = Set.empty,
-                  compiler = NixBuild,
-                  compilerFlags =
-                    map
-                      Text.pack
-                      [ path,
-                        "--out-link",
-                        root </> nixdir </> Namespace.toPath namespace,
-                        "--builders",
-                        toNixFlag builder
-                      ],
-                  out = None,
-                  outPath = outToPath None,
-                  ..
-                }
-        Namespace.Scm -> do
-          let out = detectOut (metaOut ";;") contentLines
-          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 = 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.C ->
+          Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do
+            langdepFlags <-
+              null pdep
+                ?. ( runw "pkg-config" ("--cflags" : Set.toList pdep),
+                     pure []
+                   )
+            sysdepFlags <-
+              null psys
+                ?. ( runw "pkg-config" ("--libs" : Set.toList psys),
+                     pure []
+                   )
+            Target
+              { langdeps = pdep,
+                sysdeps = psys,
+                wrapper = Nothing,
+                compiler = Gcc,
+                builder = Local user,
+                out = pout,
+                compilerFlags =
+                  concat
+                    [ [o, dir, Text.pack absPath]
+                        ++ langdepFlags
+                        ++ sysdepFlags
+                        ++ (map Text.pack <| Set.toList parg)
+                      | let outable = pout /= Meta.None,
+                        o <- outable ?: (["-o"], []),
+                        dir <- outable ?: ([Text.pack <| root </> outToPath pout], [])
+                    ],
+                outPath = outToPath pout,
+                ..
+              }
+              |> Just
+              |> pure
+        Namespace.Hs ->
+          Meta.detectOut (Meta.out "--") contentLines |> \out -> do
+            langdeps <- detectHaskellImports contentLines
+            Target
+              { builder = Local user,
+                wrapper = Nothing,
+                compiler = Ghc,
+                compilerFlags =
+                  [ "-Werror",
+                    "-i" <> root,
+                    "-odir",
+                    root </> intdir,
+                    "-hidir",
+                    root </> intdir,
+                    "--make",
+                    absPath
+                  ]
+                    ++ (out /= Meta.None)
+                    ?: ( [ "-main-is",
+                           Namespace.toHaskellModule namespace,
+                           "-o",
+                           root </> outToPath out
+                         ],
+                         []
+                       )
+                    |> 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
+            Just
+              </ pure
+                Target
+                  { sysdeps = Set.empty,
+                    wrapper = Nothing,
+                    compiler = Sbcl,
+                    compilerFlags =
+                      map
+                        Text.pack
+                        [ "--eval",
+                          "(require :asdf)",
+                          "--load",
+                          absPath,
+                          "--eval",
+                          "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)"
                         ],
-                  ..
-                }
-        Namespace.Rs -> do
-          let out = detectOut (metaOut "//") contentLines
-          Just
-            </ pure
-              Target
-                { langdeps = Set.empty,
-                  wrapper = Nothing,
-                  sysdeps = Set.empty,
-                  compiler = Rustc,
-                  compilerFlags = map Text.pack [path, "-o", root </> outToPath out],
-                  builder = Local user,
-                  outPath = outToPath out,
-                  ..
-                }
-    detectHaskellImports :: [Text] -> IO (Set Dep)
-    detectHaskellImports contentLines = do
-      let imports =
-            contentLines
-              /> Text.unpack
-              /> 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
-          /> mconcat
-      pure <| pkgs <> transitivePkgs
+                    builder = Local <| user,
+                    outPath = outToPath out,
+                    ..
+                  }
+        Namespace.Nix ->
+          (host == "lithium") ?: (Local user, Remote user "dev.simatime.com") |> \builder ->
+            Target
+              { langdeps = Set.empty,
+                wrapper = Nothing,
+                sysdeps = Set.empty,
+                compiler = NixBuild,
+                compilerFlags =
+                  [ absPath,
+                    "--out-link",
+                    root </> nixdir </> Namespace.toPath namespace,
+                    "--builders",
+                    toNixFlag builder
+                  ]
+                    |> map Text.pack,
+                out = Meta.None,
+                outPath = outToPath Meta.None,
+                ..
+              }
+              |> Just
+              |> pure
+        Namespace.Scm ->
+          Meta.detectOut (Meta.out ";;") contentLines |> \out ->
+            Target
+              { langdeps = Set.empty,
+                sysdeps = Set.empty,
+                compiler = Guile,
+                compilerFlags =
+                  [ "compile",
+                    "--r7rs",
+                    "--load-path=" ++ root,
+                    "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
+                    absPath
+                  ]
+                    |> map Text.pack,
+                builder = Local user,
+                outPath = outToPath out,
+                wrapper =
+                  [ "#!/usr/bin/env bash",
+                    "guile -C \""
+                      <> root </> intdir
+                      <> "\" -e main "
+                      <> "-s "
+                      <> Namespace.toPath namespace
+                      <> " \"$@\""
+                  ]
+                    |> joinWith "\n"
+                    |> Text.pack
+                    |> Just,
+                ..
+              }
+              |> Just
+              |> pure
+        Namespace.Rs ->
+          Meta.detectOut (Meta.out "//") contentLines |> \out ->
+            Target
+              { langdeps = Set.empty,
+                wrapper = Nothing,
+                sysdeps = Set.empty,
+                compiler = Rustc,
+                compilerFlags = map Text.pack [absPath, "-o", root </> outToPath out],
+                builder = Local user,
+                outPath = outToPath out,
+                ..
+              }
+              |> Just
+              |> pure
+    fromPath :: String -> IO (Maybe Namespace) --String ->IO (Maybe Namespace)
+    fromPath x =
+      Env.getEnv "BIZ_ROOT" +> \root ->
+        pure <| Namespace.fromPath root x
+    detectHaskellImports :: [Text] -> IO (Set Meta.Dep)
+    detectHaskellImports contentLines =
+      contentLines
+        /> Text.unpack
+        /> Regex.match haskellImports
+        |> catMaybes
+        |> \imports ->
+          foldM ghcPkgFindModule Set.empty imports
+            +> \pkgs ->
+              imports
+                |> map Namespace.fromHaskellModule
+                |> map Namespace.toPath
+                |> traverse Dir.makeAbsolute
+                +> filterM Dir.doesFileExist
+                +> traverse fromPath
+                /> 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
+                /> mconcat
+                /> (<> pkgs)
+
+    detectLispImports :: [Text] -> IO (Set Meta.Dep)
     detectLispImports contentLines = do
       let requires = contentLines /> Text.unpack /> Regex.match lispRequires |> catMaybes
       pure <| Set.fromList requires
-    detectOut m cl =
-      cl
-        /> Text.unpack
-        /> Regex.match m
-        |> catMaybes
-        |> head
-        |> fromMaybe None
-    detectMeta m cl =
-      cl
-        /> Text.unpack
-        /> Regex.match m
-        |> catMaybes
-        |> Set.fromList
 
 ghcPkgFindModule :: Set String -> String -> IO (Set String)
 ghcPkgFindModule acc m = do
@@ -655,17 +616,17 @@ build andTest loud analysis = do
           >> proc loud namespace compiler compilerFlags
         where
           label = case out of
-            Bin _ -> "bin"
+            Meta.Bin _ -> "bin"
             _ -> "lib"
       Ghc -> case out of
-        None -> pure Exit.ExitSuccess
-        Bin _ -> do
+        Meta.None -> pure Exit.ExitSuccess
+        Meta.Bin _ -> do
           Log.info ["bild", "dev", "ghc-exe", nschunk namespace]
           exitcode <- proc loud namespace compiler compilerFlags
           if andTest && isSuccess exitcode
             then test loud target
             else pure exitcode
-        Lib _ -> do
+        Meta.Lib _ -> do
           Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
           proc loud namespace compiler compilerFlags
       Guile -> do
@@ -757,33 +718,6 @@ logs ns src =
 nschunk :: Namespace -> Text
 nschunk = Namespace.toPath .> Text.pack
 
-metaDep :: [Char] -> Regex.RE Char Dep
-metaDep comment =
-  Regex.string (comment ++ " : dep ")
-    *> Regex.many (Regex.psym (not <. Char.isSpace))
-
-metaSys :: [Char] -> Regex.RE Char Dep
-metaSys comment =
-  Regex.string (comment ++ " : sys ")
-    *> Regex.many (Regex.psym (not <. Char.isSpace))
-
-metaOut :: [Char] -> Regex.RE Char Out
-metaOut comment =
-  Regex.string (comment ++ " : out ")
-    *> Regex.many (Regex.psym (/= ' '))
-    /> Bin
-
-metaLib :: [Char] -> Regex.RE Char Out
-metaLib comment =
-  Regex.string (comment ++ " : lib ")
-    *> Regex.many (Regex.psym (/= ' '))
-    /> Lib
-
-metaArg :: [Char] -> Regex.RE Char Arg
-metaArg comment =
-  Regex.string (comment ++ " : arg ")
-    *> Regex.many Regex.anySym
-
 haskellImports :: Regex.RE Char String
 haskellImports =
   Regex.string "import"
diff --git a/Biz/Bild/Meta.hs b/Biz/Bild/Meta.hs
new file mode 100644
index 0000000..75242a5
--- /dev/null
+++ b/Biz/Bild/Meta.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Small module for extracting metadata from the comments of modules.
+module Biz.Bild.Meta where
+
+import Alpha
+import qualified Data.Aeson as Aeson
+import qualified Data.Char as Char
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Text.Regex.Applicative as Regex
+
+type Dep = String
+
+type Sys = String
+
+type Arg = String
+
+data Out = Lib String | Bin String | None
+  deriving (Show, Eq)
+
+instance Aeson.ToJSON Out where
+  toJSON =
+    Aeson.String <. Text.pack <. \case
+      Bin a -> a
+      Lib a -> a
+      None -> ""
+
+data Parsed = Parsed
+  { pdep :: Set Dep,
+    parg :: Set Arg,
+    pout :: Out,
+    psys :: Set Sys
+  }
+
+detect :: Ord a => Regex.RE Char a -> [Text] -> Set a
+detect m cl =
+  cl
+    /> Text.unpack
+    /> Regex.match m
+    |> catMaybes
+    |> Set.fromList
+
+-- | 'Out' is always singular, so it gets a special function
+detectOut :: Regex.RE Char Out -> [Text] -> Out
+detectOut m cl =
+  cl
+    /> Text.unpack
+    /> Regex.match m
+    |> catMaybes
+    |> head
+    |> fromMaybe None
+
+detectAll :: [Char] -> [Text] -> Parsed
+detectAll m cl = Parsed {..}
+  where
+    pout = detectOut (out m <|> lib m) cl
+    detect_ re = detect (re m) cl
+    pdep = detect_ dep
+    psys = detect_ sys
+    parg = detect_ arg
+
+dep :: [Char] -> Regex.RE Char Dep
+dep comment =
+  Regex.string (comment ++ " : dep ")
+    *> Regex.many (Regex.psym (not <. Char.isSpace))
+
+sys :: [Char] -> Regex.RE Char Dep
+sys comment =
+  Regex.string (comment ++ " : sys ")
+    *> Regex.many (Regex.psym (not <. Char.isSpace))
+
+out :: [Char] -> Regex.RE Char Out
+out comment =
+  Regex.string (comment ++ " : out ")
+    *> Regex.many (Regex.psym (/= ' '))
+    /> Bin
+
+lib :: [Char] -> Regex.RE Char Out
+lib comment =
+  Regex.string (comment ++ " : lib ")
+    *> Regex.many (Regex.psym (/= ' '))
+    /> Lib
+
+arg :: [Char] -> Regex.RE Char Arg
+arg comment =
+  Regex.string (comment ++ " : arg ")
+    *> Regex.many Regex.anySym