Automatically detect Haskell dependencies

This parses the files contents for imports, then uses ghc-pkg to lookup the
package that provides the module. Now I can do that analysis in Haskell instead
of nix, which is much easier to code with.

1 files changed, 210 insertions, 112 deletions

diff --git a/Biz/Bild.hs b/Biz/Bild.hs
index ada7879..08fb208 100644
--- a/Biz/Bild.hs
+++ b/Biz/Bild.hs
@@ -1,19 +1,15 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | A general purpose build tool.
 --
 -- : out bild
--- : dep conduit
--- : dep conduit-extra
--- : dep docopt
--- : dep regex-applicative
--- : dep rainbow
--- : dep tasty
--- : dep tasty-hunit
 --
 -- == Design constraints
 --
@@ -75,6 +71,7 @@
 -- > bild -s <target>
 --
 -- Starts a repl/shell for target.
+--
 --  - if target.hs, load ghci
 --  - if target.scm, load scheme repl
 --  - if target.clj, load a clojure repl
@@ -92,10 +89,14 @@
 --
 -- == Build Metadata
 --
--- Metadata is set in the comments with a special syntax. For third-party deps,
+-- Metadata is set in the comments with a special syntax. For system-level deps,
 -- we list the deps in comments in the target file, like:
 --
--- > -- : dep aeson
+-- > -- : sys cmark
+--
+-- The name is used to lookup the package in `nixpkgs.pkgs.<name>`.
+-- Language-level deps can automatically determined by passing parsed import
+-- statements to a package database, eg `ghc-pkg find-module`.
 --
 -- The output executable is named with:
 --
@@ -125,22 +126,28 @@ import Biz.Namespace (Namespace (..))
 import qualified Biz.Namespace as Namespace
 import qualified Biz.Test as Test
 import qualified Control.Concurrent.Async as Async
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Char8 as Char8
+import qualified Data.ByteString.Lazy as ByteString
 import qualified Data.Char as Char
 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.List as List
+import qualified Data.Map as Map
 import qualified Data.Maybe as Maybe
+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 System.Directory as Dir
 import qualified System.Environment as Env
 import qualified System.Exit as Exit
 import System.FilePath (replaceExtension, (</>))
 import qualified System.IO as IO
+import qualified System.Process as Process
 import qualified Text.Regex.Applicative as Regex
-import qualified Prelude
 
 main :: IO ()
 main = Cli.main <| Cli.Plan help move test pure
@@ -149,8 +156,7 @@ main = Cli.main <| Cli.Plan help move test pure
       Test.group
         "Biz.Bild"
         [ Test.unit "can bild bild" <| do
-            let ns = Namespace ["Biz", "Bild"] Namespace.Hs
-            analyze ns +> build False False +> \case
+            analyze "Biz/Bild.hs" /> Maybe.fromJust +> build False False +> \case
               Exit.ExitFailure _ -> Test.assertFailure "can't bild bild"
               _ -> pure ()
         ]
@@ -158,16 +164,28 @@ main = Cli.main <| Cli.Plan help move test pure
 move :: Cli.Arguments -> IO ()
 move args =
   IO.hSetBuffering stdout IO.NoBuffering
-    >> traverse getNamespace (Cli.getAllArgs args (Cli.argument "target"))
-    /> catMaybes
-    /> filter isBuildableNs
-    +> traverse analyze
-    +> traverse
-      ( build
-          (args `Cli.has` Cli.longOption "test")
-          (args `Cli.has` Cli.longOption "loud")
-      )
+    >> pure (Cli.getAllArgs args (Cli.argument "target"))
+    /> filter (not <. ("_" `List.isPrefixOf`))
+    +> filterM Dir.doesFileExist
+    +> traverse (\fn -> analyze fn /> (fn,))
+    /> filter (snd .> isJust)
+    /> Map.fromList
+    /> Map.map Maybe.fromJust
+    /> Map.filter (namespace .> isBuildableNs)
+    +> printOrBuild
     +> exitSummary
+  where
+    printOrBuild :: Map FilePath Target -> IO [ExitCode]
+    printOrBuild analyses =
+      if args `Cli.has` Cli.longOption "analyze"
+        then Map.elems analyses |> putJSON >> pure [Exit.ExitSuccess]
+        else Map.toList analyses |> map snd |> traverse (build isTest isLoud)
+    isTest = args `Cli.has` Cli.longOption "test"
+    isLoud = args `Cli.has` Cli.longOption "loud"
+    putJSON = Aeson.encode .> ByteString.toStrict .> Char8.putStrLn
+
+nixStore :: String
+nixStore = "/nix/store/00000000000000000000000000000000-"
 
 help :: Cli.Docopt
 help =
@@ -179,9 +197,10 @@ Usage:
   bild [options] <target>...
 
 Options:
-  --test  Run tests on a target after building.
-  --loud  Show all output from compiler.
-  --help  Print this info
+  --test      Run tests on a target after building
+  --loud      Show all output from compiler
+  --analyze   Only analyze and print as JSON, don't build
+  -h, --help  Print this info
 |]
 
 exitSummary :: [Exit.ExitCode] -> IO ()
@@ -204,7 +223,7 @@ data Compiler
   | Guile
   | NixBuild
   | Copy
-  deriving (Show)
+  deriving (Show, Generic, Aeson.ToJSON)
 
 data Target = Target
   { -- | Output name
@@ -213,14 +232,16 @@ data Target = Target
     namespace :: Namespace,
     -- | Absolute path to file
     path :: FilePath,
-    -- | Parsed/detected dependencies
-    deps :: [Dep],
+    -- | Language-specific dependencies
+    langdeps :: Set Dep,
+    -- | System-level dependencies
+    sysdeps :: Set Dep,
     -- | Which compiler should we use?
     compiler :: Compiler,
     -- | Where is this machine being built? Schema: user@location
     builder :: Text
   }
-  deriving (Show)
+  deriving (Show, Generic, Aeson.ToJSON)
 
 -- | We can't build everything yet...
 isBuildableNs :: Namespace -> Bool
@@ -246,7 +267,7 @@ vardir = "_/var"
 
 createHier :: String -> IO ()
 createHier root =
-  mapM_
+  traverse_
     (Dir.createDirectoryIfMissing True)
     [ root </> bindir,
       root </> intdir,
@@ -254,74 +275,135 @@ createHier root =
       root </> vardir
     ]
 
-getNamespace :: String -> IO (Maybe Namespace)
-getNamespace s = do
+-- >>> removeVersion "array-0.5.4.0-DFLKGIjfsadi"
+-- "array"
+removeVersion :: String -> String
+removeVersion = takeWhile (/= '.') .> butlast2
+  where
+    butlast2 s = take (length s - 2) s
+
+detectImports :: Namespace -> [Text] -> IO (Set Dep)
+detectImports (Namespace _ Namespace.Hs) contentLines = do
+  let imports =
+        contentLines
+          /> Text.unpack
+          /> Regex.match haskellImports
+          |> catMaybes
+  pkgs <- foldM ghcPkgFindModule Set.empty imports
+  transitivePkgs <-
+    imports
+      |> map (Namespace.fromHaskellModule .> Namespace.toPath)
+      |> traverse Dir.makeAbsolute
+      +> filterM Dir.doesFileExist
+      +> traverse analyze -- surely this is a bottleneck ripe for caching
+      /> catMaybes
+      /> map langdeps
+      /> mconcat
+  pure <| pkgs <> transitivePkgs
+detectImports _ _ = Exit.die "can only detectImports for Haskell"
+
+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"
-  cwd <- Dir.getCurrentDirectory
-  return <| Namespace.fromPath root <| cwd </> s
-
-analyze :: Namespace -> IO Target
-analyze namespace@(Namespace.Namespace _ ext) = do
-  user <- Env.getEnv "USER" /> Text.pack
-  host <- chomp </ readFile "/etc/hostname"
-  let path = Namespace.toPath namespace
-  case ext of
-    Namespace.Hs -> do
-      content <- String.lines </ Prelude.readFile path
-      let out =
-            content
-              /> Regex.match (metaOut "--")
-              |> catMaybes
-              |> head
-      return
-        Target
-          { deps = content /> Regex.match metaDep |> catMaybes,
-            builder = user <> "@localhost",
-            compiler = detectGhcCompiler out <| String.unlines content,
-            ..
-          }
-    Namespace.Nix ->
-      return
-        Target
-          { deps = [],
-            compiler = NixBuild,
-            out = Nothing,
-            builder =
-              if host == "lithium"
-                then mempty
-                else
-                  Text.concat
-                    [ "ssh://",
-                      user,
-                      "@dev.simatime.com?ssh-key=/home/",
-                      user,
-                      "/.ssh/id_rsa"
-                    ],
-            ..
-          }
-    Namespace.Scm -> do
-      content <- String.lines </ Prelude.readFile path
-      return
-        Target
-          { deps = [],
-            compiler = Guile,
-            out =
-              content
-                /> Regex.match (metaOut ";;")
-                |> catMaybes
-                |> head,
-            builder = user <> "@localhost",
-            ..
-          }
-    _ ->
-      return
-        Target
-          { deps = [],
-            compiler = Copy,
-            out = Nothing,
-            builder = user <> "@localhost",
-            ..
-          }
+  absPath <- Dir.makeAbsolute path
+  Log.info ["bild", "analyze", str path]
+  let ns =
+        if "hs" `List.isSuffixOf` path
+          then Namespace.fromContent <| Text.unpack content
+          else Namespace.fromPath root absPath
+  case ns of
+    Nothing ->
+      Log.warn ["bild", "analyze", str path, "could not find namespace"]
+        >> Log.br
+        >> pure Nothing
+    Just namespace@(Namespace _ ext) ->
+      Just </ do
+        user <- Env.getEnv "USER" /> Text.pack
+        host <- Text.pack </ fromMaybe "interactive" </ Env.lookupEnv "HOSTNAME"
+        case ext of
+          Namespace.Hs -> do
+            langdeps <- detectImports namespace contentLines
+            let out =
+                  contentLines
+                    /> Text.unpack
+                    /> Regex.match (metaOut "--")
+                    |> catMaybes
+                    |> head
+            pure
+              Target
+                { builder = user <> "@localhost",
+                  compiler = detectGhcCompiler out <| Text.unpack content,
+                  sysdeps =
+                    contentLines
+                      /> Text.unpack
+                      /> Regex.match (metaSys "--")
+                      |> catMaybes
+                      |> Set.fromList,
+                  ..
+                }
+          Namespace.Nix ->
+            pure
+              Target
+                { langdeps = Set.empty,
+                  sysdeps = Set.empty,
+                  compiler = NixBuild,
+                  out = Nothing,
+                  builder =
+                    if host == "lithium"
+                      then mempty
+                      else
+                        Text.concat
+                          [ "ssh://",
+                            user,
+                            "@dev.simatime.com?ssh-key=/home/",
+                            user,
+                            "/.ssh/id_rsa"
+                          ],
+                  ..
+                }
+          Namespace.Scm -> do
+            pure
+              Target
+                { langdeps = Set.empty,
+                  sysdeps = Set.empty,
+                  compiler = Guile,
+                  out =
+                    contentLines
+                      /> Text.unpack
+                      /> Regex.match (metaOut ";;")
+                      |> catMaybes
+                      |> head,
+                  builder = user <> "@localhost",
+                  ..
+                }
+          _ ->
+            pure
+              Target
+                { langdeps = Set.empty,
+                  sysdeps = Set.empty,
+                  compiler = Copy,
+                  out = Nothing,
+                  builder = user <> "@localhost",
+                  ..
+                }
+
+ghcPkgFindModule :: Set String -> String -> IO (Set String)
+ghcPkgFindModule acc m =
+  Process.readProcess
+    "ghc-pkg"
+    -- instead of relying on global deps declared in ./Bild/Deps/Haskell.nix, I
+    -- could fetch a global package-db from hackage API and pass it here with
+    -- --package-db=FILE
+    ["--names-only", "--simple-output", "find-module", m]
+    ""
+    /> String.lines
+    /> Set.fromList
+    /> Set.union acc
 
 -- | Some rules for detecting the how to compile a ghc module. If there is an
 -- out, then we know it's some Exe; if the out ends in .js then it's GhcjsExe,
@@ -332,7 +414,7 @@ analyze namespace@(Namespace.Namespace _ ext) = do
 -- import list.
 detectGhcCompiler :: Maybe Out -> String -> Compiler
 detectGhcCompiler (Just out) _ | jsSuffix out = GhcjsExe
-detectGhcCompiler (Just out) _ | not <| jsSuffix out = GhcExe
+detectGhcCompiler (Just _) _ = GhcExe
 detectGhcCompiler Nothing content
   | match "import GHCJS" = GhcjsLib
   | otherwise = GhcLib
@@ -386,7 +468,7 @@ build andTest loud Target {..} = do
                 onFailure = Log.fail ["test", nschunk namespace] >> Log.br,
                 onSuccess = Log.pass ["test", nschunk namespace] >> Log.br
               }
-        else return exitcode
+        else pure exitcode
     GhcLib -> do
       Log.info ["bild", "dev", "ghc-lib", nschunk namespace]
       proc
@@ -440,16 +522,17 @@ build andTest loud Target {..} = do
     --  ]
     Guile -> do
       Log.info ["bild", "dev", "guile", nschunk namespace]
-      proc
-        loud
-        namespace
-        "guild"
-        [ "compile",
-          "--r7rs",
-          "--load-path=" ++ root,
-          "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
-          path
-        ]
+      _ <-
+        proc
+          loud
+          namespace
+          "guild"
+          [ "compile",
+            "--r7rs",
+            "--load-path=" ++ root,
+            "--output=" ++ root </> intdir </> replaceExtension path ".scm.go",
+            path
+          ]
       when (isJust out) <| do
         let o = Maybe.fromJust out
         writeFile
@@ -467,7 +550,7 @@ build andTest loud Target {..} = do
             ]
         p <- Dir.getPermissions <| root </> bindir </> o
         Dir.setPermissions (root </> bindir </> o) (Dir.setOwnerExecutable True p)
-      return Exit.ExitSuccess
+      pure Exit.ExitSuccess
     NixBuild -> do
       Log.info
         [ "bild",
@@ -489,7 +572,7 @@ build andTest loud Target {..} = do
         ]
     Copy -> do
       Log.warn ["bild", "copy", "TODO", nschunk namespace]
-      return Exit.ExitSuccess
+      pure Exit.ExitSuccess
 
 data Proc = Proc
   { loud :: Bool,
@@ -515,8 +598,8 @@ run Proc {..} = do
           <| Async.Concurrently
           <| Conduit.waitForStreamingProcess cph
   if isFailure exitcode
-    then puts stderr_ >> onFailure >> return exitcode
-    else onSuccess >> return exitcode
+    then puts stderr_ >> onFailure >> pure exitcode
+    else onSuccess >> pure exitcode
 
 -- | Helper for running a standard bild subprocess.
 proc :: Bool -> Namespace -> String -> [String] -> IO Exit.ExitCode
@@ -541,5 +624,20 @@ nschunk = Namespace.toPath .> Text.pack
 metaDep :: Regex.RE Char Dep
 metaDep = Regex.string "-- : dep " *> Regex.many (Regex.psym Char.isAlpha)
 
+metaSys :: [Char] -> Regex.RE Char Dep
+metaSys comment = Regex.string (comment ++ " : sys ") *> Regex.many (Regex.psym Char.isAlpha)
+
 metaOut :: [Char] -> Regex.RE Char Out
 metaOut comment = Regex.string (comment ++ " : out ") *> Regex.many (Regex.psym (/= ' '))
+
+haskellImports :: Regex.RE Char String
+haskellImports =
+  Regex.string "import"
+    *> Regex.some (Regex.psym Char.isSpace)
+    *> Regex.many (Regex.psym Char.isLower)
+    *> Regex.many (Regex.psym Char.isSpace)
+    *> Regex.some (Regex.psym isModuleChar)
+    <* Regex.many Regex.anySym
+  where
+    isModuleChar c =
+      elem c <| concat [['A' .. 'Z'], ['a' .. 'z'], ['.', '_'], ['0' .. '9']]