#!/usr/bin/env run.sh
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | A specific-purpose build tool.
--
-- : out bild
-- : run git
--
-- == Design constraints
--
--    * The only input is one or more a namespaces. No subcommands, no packages,
--      no targets.
--
--    * No need to write specific build rules. One rule for hs, one for rs, one
--      for scm, and so on.
--
--    * No need to distinguish between exe and lib because we only build
--      exes; 'libs' are just source files in the tree.
--
--    * Never concerned with deployment/packaging - leave that to another tool
--      (scp? tar?)
--
--    * Ability to do local dev builds should be preserved, while remote nix
--      builds are used for the final package.
--
-- == Features
--
--    * Namespace maps to filesystem
--
--        * no need for `bild -l` for listing available targets.
--          Use `ls` or `tree`
--
--        * you build namespaces, not files/modules/packages/etc
--
--    * Namespace maps to language modules
--
--        * build settings can be set in the file comments, or special 'bild'
--          args
--
--    * pwd is always considered the the source directory,
--      no `src` vs `doc` etc.
--
--    * Build rules automaticatly detected from file extensions
--
--    * Flags modify the way to interact with the build, some ideas:
--
--        * -p = turn on profiling
--
--        * -o = optimize level
--
--    * The build is planned out with an analysis, which can be viewed
--      beforehand with `--plan`. The analysis includes compiler flags, which
--      can be used in `repl` for testing compilation locally.
--
--    * (WIP) Nix is used by default to build everything on a remote build
--      machine, but local, non-Nix builds can be accomplished with `--dev`.
--
-- == Example Commands
--
-- > bild [opts] <target..>
--
-- The general scheme is to build the things described by the targets. A target
-- is a namespace. You can list as many as you want, but you must list at least
-- one. It could just be `:!bild %` in vim to build whatever you're working on,
-- or `bild **/*` to build everything, or `fd .hs -X bild` to build all Haskell
-- files.
--
-- Build outputs will go into the `_` directory in the root of the project.
--
-- > bild A/B.hs
--
-- This will build the file at ./A/B.hs, which translates to something like
-- `ghc --make A.B`.
--
-- == Build Metadata
--
-- 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:
--
-- > -- : sys cmark
-- > -- : sys libssl
--
-- The name is used to lookup the package in `nixpkgs.pkgs.<name>`. Only one
-- package can be listed per line. Language-level deps can automatically
-- determined by passing parsed import statements to a package database, eg
-- `ghc-pkg find-module`. If such a package database is not available, we either
-- keep a hand-written index that maps imports to packages, or we just list the
-- name of the package with:
--
-- > -- : dep package
--
-- The output executable is named with:
--
-- > -- : out my-program
--
-- or
--
-- > -- : out my-app.js
--
-- When multiple compilers are possible we use the @out@ extension to determine
-- target platform. If @out@ does not have an extension, each build type falls
-- back to a default, namely an executable binary.
--
-- This method of setting metadata in the module comments works pretty well,
-- and really only needs to be done in the entrypoint module anyway.
--
-- Local module deps are included by just giving the repo root to the underlying
-- compiler for the target, and the compiler does the work of walking the source
-- tree.
module Omni.Bild where

import Alpha hiding (sym, (<.>))
import qualified Conduit
import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.QSemN as QSemN
import Control.Concurrent.STM (TQueue, TVar, modifyTVar', newTQueue, newTVar, readTVar, readTVarIO, tryReadTQueue, writeTQueue)
import qualified Control.Exception as Exception
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Lazy as ByteString.Lazy
import qualified Data.Char as Char
import Data.Conduit ((.|))
import qualified Data.Conduit.Combinators as Conduit
import qualified Data.Conduit.Process as Conduit
import Data.Graph (SCC (..), stronglyConnComp)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List (partition)
import qualified Data.List as List
import qualified Data.Map as Map
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 GHC.Conc as GHC
import qualified Network.HostName as HostName
import qualified Numeric
import qualified Omni.Bild.Meta as Meta
import qualified Omni.Cli as Cli
import qualified Omni.Log as Log
import qualified Omni.Log.Concurrent as LogC
import Omni.Namespace (Namespace (..))
import qualified Omni.Namespace as Namespace
import Omni.Test ((@=?))
import qualified Omni.Test as Test
import qualified System.Directory as Dir
import qualified System.Environment as Env
import qualified System.Exit as Exit
import System.FilePath (dropExtension, replaceExtension, takeDirectory, (</>))
import qualified System.IO as IO
import System.IO.Unsafe (unsafePerformIO)
import qualified System.Process as Process
import qualified System.Timeout as Timeout
import qualified Text.Regex.Applicative as Regex

mapConcurrentlyBounded :: Int -> (a -> IO b) -> [a] -> IO [b]
mapConcurrentlyBounded n f xs = do
  sem <- QSemN.newQSemN n
  Async.forConcurrently xs <| \x ->
    Exception.bracket_
      (QSemN.waitQSemN sem 1)
      (QSemN.signalQSemN sem 1)
      (f x)

main :: IO ()
main = Cli.Plan help move test_ pure |> Cli.main
  where
    test_ =
      Test.group
        "Omni.Bild"
        [ test_bildBild,
          test_bildExamples,
          test_isGitIgnored,
          test_isGitHook,
          test_detectPythonImports,
          test_buildHsModuleGraph
        ]

test_bildBild :: Test.Tree
test_bildBild =
  Test.unit "can bild bild" <| do
    root <- getCoderoot
    path <- Dir.makeAbsolute "Omni/Bild.hs"
    case Namespace.fromPath root path of
      Nothing -> Test.assertFailure "can't find ns for bild"
      Just ns ->
        analyzeAll True [ns]
          +> build False True 1 2
          +> \case
            [Exit.ExitFailure _] ->
              Test.assertFailure "can't bild bild"
            _ ->
              pure ()

test_bildExamples :: Test.Tree
test_bildExamples =
  Test.unit "can bild examples" <| do
    getCoderoot +> \root ->
      ["c", "hs", "lisp", "rs"]
        |> map ("Omni/Bild/Example." <>)
        |> traverse Dir.makeAbsolute
        /> map (Namespace.fromPath root)
        /> catMaybes
        +> analyzeAll True
        +> build False True 4 1
        +> \case
          [] -> Test.assertFailure "asdf"
          xs -> all (== Exit.ExitSuccess) xs @=? True

move :: Cli.Arguments -> IO ()
move args = do
  IO.hSetBuffering stdout IO.NoBuffering
  root <- getCoderoot
  loadGhcPkgCache
  allNamespaces <-
    Cli.getAllArgs args (Cli.argument "target")
      |> filterM Dir.doesFileExist
      +> filterGitIgnored
      /> filter (\x -> isGitHook x |> don't)
      +> traverse Dir.makeAbsolute
      +> traverse (namespaceFromPathOrDie root)
  let (namespaces, skippedNamespaces) = partition isBuildableNs allNamespaces
  let isPlanMode = args `Cli.has` Cli.longOption "plan"
  if isPlanMode
    then do
      analysis <- analyzeAll True namespaces
      if Map.null analysis
        then Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1)
        else putJSON analysis
    else do
      when (null allNamespaces) <| do
        Log.wipe >> Log.fail ["bild", "nothing to build"] >> Log.br >> exitWith (ExitFailure 1)
      nproc <- GHC.getNumProcessors
      createHier root
      let runWithManager action =
            if isLoud
              then action
              else
                LogC.withLineManager allNamespaces <| \mgr -> do
                  LogC.initializeLines mgr
                  forM_ skippedNamespaces <| \ns -> LogC.updateLineState ns LogC.Skipped
                  action
      runWithManager <| do
        pipelineBuild isTest isLoud 8 jobs (cpus nproc) namespaces analyzeOne
          |> Timeout.timeout (toMillis minutes)
          +> \case
            Nothing ->
              Log.br
                >> Log.fail ["bild", "timeout after " <> tshow minutes <> " minutes"]
                >> Log.br
                >> exitWith (ExitFailure 124)
            Just s -> do
              when (all isSuccess s) saveGhcPkgCache
              exitSummary s
  where
    minutes =
      Cli.getArgWithDefault args "10" (Cli.longOption "time")
        |> readMaybe
        |> \case
          Nothing -> panic "could not read --time argument"
          Just n -> (n == 0) ?: (-1, n)
    cpus :: Int -> Int
    cpus nproc =
      Cli.longOption "cpus"
        |> Cli.getArgWithDefault args (str <| (nproc - 4) `div` jobs)
        |> readMaybe
        |> \case
          Nothing -> panic "could not read --cpus argument"
          Just n -> n
    jobs :: Int
    jobs =
      Cli.longOption "jobs"
        |> Cli.getArgWithDefault args "6"
        |> readMaybe
        |> \case
          Nothing -> panic "could not read --jobs argument"
          Just n -> n
    isTest = args `Cli.has` Cli.longOption "test"
    isLoud = args `Cli.has` Cli.longOption "loud"
    putJSON = Aeson.encode .> ByteString.Lazy.toStrict .> Char8.putStrLn

-- | Don't try to build stuff that isn't part of the git repo.
isGitIgnored :: FilePath -> IO Bool
isGitIgnored path =
  Process.readProcessWithExitCode "git" ["check-ignore", path] ""
    +> \case
      (ExitSuccess, _, _) -> pure True
      (ExitFailure _, _, _) -> pure False

filterGitIgnored :: [FilePath] -> IO [FilePath]
filterGitIgnored [] = pure []
filterGitIgnored paths = do
  (exitCode, out, _) <-
    Process.readProcessWithExitCode
      "git"
      ["check-ignore", "--stdin"]
      (List.intercalate "\n" paths)
  case exitCode of
    ExitSuccess ->
      let ignoredPaths = Set.fromList (String.lines out)
       in pure [p | p <- paths, don't (Set.member p ignoredPaths)]
    ExitFailure _ -> pure paths

test_isGitIgnored :: Test.Tree
test_isGitIgnored =
  Test.group
    "isGitIgnored"
    [ Test.unit "filters one" <| do
        res <- isGitIgnored "_"
        res @=? True,
      Test.unit "filters many" <| do
        traverse isGitIgnored ["Omni/Bild.hs", "TAGS"]
          +> (@=? [False, True])
    ]

isGitHook :: FilePath -> Bool
isGitHook path =
  "Omni/Ide/hooks" `List.isInfixOf` path

test_isGitHook :: Test.Tree
test_isGitHook =
  Test.group
    "isGitHook"
    [ Test.unit "filters pre-commit hook" <| do
        root <- getCoderoot
        True @=? (isGitHook <| root <> "/Omni/Ide/hooks/pre-commit"),
      Test.unit "doesn't filter non-hooks" <| do
        root <- getCoderoot
        False @=? (isGitHook <| root <> "/Omni/Bild.hs")
    ]

namespaceFromPathOrDie :: FilePath -> FilePath -> IO Namespace
namespaceFromPathOrDie root path =
  Namespace.fromPath root path |> \case
    Just x -> pure x
    Nothing ->
      Log.fail ["bild", str path, "could not get namespace"]
        >> Log.br
        >> exitWith (ExitFailure 1)

nixStore :: String
nixStore = "/nix/store/00000000000000000000000000000000-"

help :: Cli.Docopt
help =
  [Cli.docopt|
bild

Usage:
  bild test
  bild [options] <target>...
  bild --help

Options:
  --test, -t      Run tests on a target after building
  --loud, -l      Show all output from compiler
  --plan, -p      Print the build plan as JSON, don't build
  --time N        Set timeout to N minutes, 0 means never timeout [default: 10]
  --jobs N, -j N  Build up to N jobs at once [default: 6]
  --cpus N, -c N  Allocate up to N cpu cores per job (default: (nproc-4)/jobs)
  --help, -h      Print this info
|]

exitSummary :: [Exit.ExitCode] -> IO ()
exitSummary exits =
  if failures > 0
    then Exit.die <| show failures
    else Exit.exitSuccess
  where
    failures = length <| filter isFailure exits

data Compiler
  = Copy
  | CPython
  | Gcc
  | Ghc
  | Guile
  | NixBuild
  | Rustc
  | Sbcl
  deriving (Eq, Show, Generic)

compilerExe :: (IsString a) => Compiler -> a
compilerExe = \case
  Copy -> "cp"
  CPython -> "python"
  Gcc -> "gcc"
  Ghc -> "ghc"
  Guile -> "guild"
  NixBuild -> "nix-build"
  Rustc -> "rustc"
  Sbcl -> "sbcl"

instance Aeson.ToJSON Compiler where
  toJSON = Aeson.String <. compilerExe

instance ToNixFlag Compiler where
  toNixFlag = compilerExe

-- | Type alias for making sure that the path is qualified, meaning it starts at
-- the root of the repo, and is not an absolute path nor a subpath
type QualifiedPath = FilePath

data Target = Target
  { -- | Output name
    out :: Meta.Out,
    -- | Output path (into cabdir)
    outPath :: FilePath,
    -- | Fully qualified namespace partitioned by '.'
    namespace :: Namespace,
    -- | Path to file, qualified based on the root of the git directory
    quapath :: QualifiedPath,
    -- | Main module name, formatted as the language expects
    mainModule :: String,
    -- | Name of the packageset in Bild.nix to pull langdeps from
    packageSet :: Text,
    -- | Language-specific dependencies, required during compilation
    langdeps :: Set Meta.Dep,
    -- | Local source files on which this target depends
    srcs :: Set FilePath,
    -- | 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,
    -- | Which nix build expression?
    builder :: Text,
    -- | Who is building this?
    user :: Text,
    -- | Where are they buildint it?
    host :: Text,
    -- | Flags and arguments passed to 'Compiler' when building
    compilerFlags :: [Text],
    -- | Wrapper script (if necessary)
    wrapper :: Maybe Text,
    -- | Runtime dependences
    rundeps :: Set Meta.Run,
    -- | Haskell module graph for per-module builds (Nothing means fallback to monolithic)
    hsGraph :: Maybe HsModuleGraph
  }
  deriving (Show, Generic, Aeson.ToJSON)

type ModuleName = Text

data HsModuleNode = HsModuleNode
  { nodePath :: FilePath,
    nodeImports :: [ModuleName],
    nodeHasTH :: Bool
  }
  deriving (Show, Generic, Aeson.ToJSON)

data HsModuleGraph = HsModuleGraph
  { graphEntry :: ModuleName,
    graphModules :: Map ModuleName HsModuleNode
  }
  deriving (Show, Generic, Aeson.ToJSON)

-- | Use this to just get a target to play with at the repl.
dev_getTarget :: FilePath -> IO Target
dev_getTarget fp = do
  root <- getCoderoot
  path <- Dir.makeAbsolute fp
  Namespace.fromPath root path
    |> \case
      Nothing -> panic "Could not get namespace from path"
      Just ns ->
        analyzeAll False [ns]
          /> Map.lookup ns
          /> \case
            Nothing -> panic "Could not retrieve target from analysis"
            Just t -> t

data Builder
  = -- | Local <user> <host>
    Local Text Text
  | -- | Remote <user> <host>
    Remote Text Text
  deriving (Show, Generic)

instance Aeson.ToJSON Builder where
  toJSON (Local u host) = Aeson.String <| u <> "@" <> host
  toJSON (Remote u host) = Aeson.String <| u <> "@" <> host

class ToNixFlag a where
  toNixFlag :: a -> String

instance ToNixFlag Builder where
  toNixFlag = \case
    Local _ _ -> mempty
    Remote u h -> Text.unpack <| Text.concat ["ssh://", u, "@", h, "?ssh-key=/home/", u, "/.ssh/id_rsa"]

-- | We can't build everything yet...
isBuildableNs :: Namespace -> Bool
isBuildableNs = \case
  (Namespace _ Namespace.C) -> True
  (Namespace _ Namespace.Css) -> False
  (Namespace _ Namespace.Hs) -> True
  (Namespace _ Namespace.Html) -> False
  (Namespace _ Namespace.Json) -> False
  (Namespace _ Namespace.Keys) -> False
  (Namespace _ Namespace.Lisp) -> True
  (Namespace _ Namespace.Md) -> False
  (Namespace _ Namespace.Nix) -> True
  (Namespace _ Namespace.None) -> False
  (Namespace _ Namespace.Py) -> True
  (Namespace _ Namespace.Sh) -> False
  (Namespace _ Namespace.Scm) -> True
  (Namespace _ Namespace.Rs) -> True
  (Namespace _ Namespace.Toml) -> False

-- | The default output directory. This is not IO because I don't want to
-- refactor all of my code right now, but it probably should be.
cab :: FilePath
cab =
  Env.lookupEnv "CABDIR"
    /> fromMaybe "_"
    |> unsafePerformIO

outToPath :: Meta.Out -> FilePath
outToPath = \case
  Just o -> cab </> "bin" </> o
  Nothing -> mempty

outname :: Meta.Out -> FilePath
outname = \case
  Just o -> o
  Nothing -> mempty

bindir, intdir, nixdir, vardir :: FilePath
bindir = cab </> "bin"
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 <| Just ""),
      root </> intdir,
      root </> nixdir,
      root </> vardir
    ]

-- >>> removeVersion "array-0.5.4.0-DFLKGIjfsadi"
-- "array"
removeVersion :: String -> String
removeVersion = takeWhile (/= '.') .> butlast2
  where
    butlast2 s = take (length s - 2) s

type Analysis = Map Namespace Target

analyzeAll :: Bool -> [Namespace] -> IO Analysis
analyzeAll _isPlanMode nss = do
  targets <- mapConcurrentlyBounded 8 analyzeOne nss
  pure <| Map.fromList <| catMaybes <| zipWith (\ns mt -> (ns,) </ mt) nss targets

analyzeOne :: Namespace -> IO (Maybe Target)
analyzeOne namespace@(Namespace parts ext) = do
  let path = Namespace.toPath namespace
  root <- getCoderoot
  let abspath = root </> path
  let quapath = path
  user <- Env.getEnv "USER" /> Text.pack
  host <- HostName.getHostName /> Text.pack
  contentLines <-
    withFile abspath ReadMode <| \h ->
      IO.hSetEncoding h IO.utf8_bom
        >> Text.IO.hGetContents h
        /> Text.lines
  isExe <- Dir.getPermissions quapath /> Dir.executable
  let defaultOut = isExe ?: (Just <| Namespace.dotSeparated parts, Nothing)
  case ext of
    Namespace.Css -> pure Nothing
    Namespace.Json -> pure Nothing
    Namespace.Keys -> pure Nothing
    Namespace.Md -> pure Nothing
    Namespace.None -> pure Nothing
    Namespace.Html -> pure Nothing
    Namespace.Toml -> pure Nothing
    Namespace.Py ->
      contentLines
        |> Meta.detectAll "#"
        |> \Meta.Parsed {..} ->
          detectPythonImports mempty contentLines +> \(srcs, transitiveDeps) ->
            Target
              { builder = "python",
                wrapper = Nothing,
                compiler = CPython,
                compilerFlags =
                  -- This doesn't really make sense for python, but I'll leave
                  -- it here for eventual --dev builds
                  [ "-c",
                    "\"import py_compile;import os;"
                      <> "py_compile.compile(file='"
                      <> str quapath
                      <> "', cfile=os.getenv('CODEROOT')+'/_/int/"
                      <> str quapath
                      <> "', doraise=True)\""
                  ],
                sysdeps = psys,
                langdeps = pdep <> transitiveDeps,
                outPath = outToPath pout,
                out = pout <|> defaultOut,
                packageSet = "python.packages",
                mainModule = Namespace.toModule namespace,
                rundeps = prun,
                hsGraph = Nothing,
                ..
              }
              |> Just
              |> pure
    Namespace.Sh -> pure Nothing
    Namespace.C ->
      Meta.detectAll "//" contentLines |> \Meta.Parsed {..} -> do
        Target
          { langdeps = pdep,
            sysdeps = psys,
            wrapper = Nothing,
            compiler = Gcc,
            builder = "c",
            out = pout <|> defaultOut,
            packageSet = "c.packages",
            mainModule = Namespace.toModule namespace,
            compilerFlags = case pout of
              Just o ->
                ["-o", o, path] <> Set.toList parg |> map Text.pack
              Nothing -> panic "can only bild C exes, not libs",
            outPath = outToPath pout,
            -- implement detectCImports, then I can fill this out
            srcs = Set.empty,
            rundeps = prun,
            hsGraph = Nothing,
            ..
          }
          |> Just
          |> pure
    Namespace.Hs ->
      contentLines
        |> Meta.detectAll "--"
        |> \Meta.Parsed {..} ->
          detectHaskellImports mempty contentLines +> \(autoDeps, srcs) -> do
            let langdeps = autoDeps <> pdep
            graph <- buildHsModuleGraph namespace quapath srcs
            pure
              <| Just
                Target
                  { builder = "haskell",
                    wrapper = Nothing,
                    compiler = Ghc,
                    packageSet = "haskell.packages",
                    mainModule = Namespace.toModule namespace,
                    compilerFlags =
                      [ "-Wall",
                        "-Werror",
                        "-haddock",
                        "-Winvalid-haddock",
                        "-threaded",
                        "-i$CODEROOT",
                        "-odir",
                        ".",
                        "-hidir",
                        ".",
                        "--make",
                        "$CODEROOT" </> quapath
                      ]
                        ++ case pout of
                          Just o ->
                            [ "-main-is",
                              Namespace.toHaskellModule namespace,
                              "-o",
                              o
                            ]
                          Nothing -> []
                        |> map Text.pack,
                    sysdeps = Meta.detect (Meta.sys "--") contentLines,
                    outPath = outToPath pout,
                    rundeps = prun,
                    out = pout <|> defaultOut,
                    hsGraph = graph,
                    ..
                  }
    Namespace.Lisp ->
      Meta.detectOut (Meta.out ";;") contentLines |> \out -> do
        langdeps <- detectLispImports contentLines
        Just
          </ pure
            Target
              { sysdeps = Set.empty,
                wrapper = Nothing,
                compiler = Sbcl,
                packageSet = "lisp.sbclWith",
                mainModule = Namespace.toModule namespace,
                compilerFlags =
                  map
                    Text.pack
                    [ "--eval",
                      "(require :asdf)",
                      "--load",
                      quapath,
                      "--eval",
                      "(sb-ext:save-lisp-and-die #p\"" <> (root </> outToPath out) <> "\" :toplevel #'main :executable t)"
                    ],
                builder = "base",
                outPath = outToPath out,
                -- add local src imports to detectLispImports, then i can fill this out
                srcs = Set.empty,
                rundeps = Set.empty,
                hsGraph = Nothing,
                ..
              }
    Namespace.Nix ->
      (host == "lithium") ?: (Local user "lithium", Remote user "dev.bensima.com") |> \builder ->
        Target
          { langdeps = Set.empty,
            wrapper = Nothing,
            sysdeps = Set.empty,
            compiler = NixBuild,
            compilerFlags =
              [ quapath,
                "--out-link",
                root </> nixdir </> Namespace.toPath namespace,
                "--builders",
                toNixFlag builder,
                "--arg",
                "bild",
                str <| "import " <> root </> "Omni/Bild.nix {}"
              ]
                |> map Text.pack,
            out = Nothing,
            outPath = outToPath Nothing,
            srcs = Set.empty,
            packageSet = "",
            mainModule = Namespace.toModule namespace,
            builder = "base",
            rundeps = Set.empty,
            hsGraph = Nothing,
            ..
          }
          |> Just
          |> pure
    Namespace.Scm ->
      Meta.detectAll ";;" contentLines |> \Meta.Parsed {..} ->
        Target
          { langdeps = pdep,
            sysdeps = psys,
            compiler = Guile,
            packageSet = "scheme.guilePackages",
            mainModule = Namespace.toModule namespace,
            compilerFlags =
              [ "compile",
                "--r7rs",
                "--load-path=" ++ root,
                "--output=" ++ root </> intdir </> replaceExtension quapath ".scm.go",
                quapath
              ]
                |> map Text.pack,
            builder = "base",
            outPath = outToPath pout,
            out = pout <|> defaultOut,
            srcs = Set.empty, -- implement detectSchemeImports
            -- TODO: wrapper should just be removed, instead rely on
            -- upstream nixpkgs builders to make wrappers
            wrapper =
              isNothing pout
                ?: ( Nothing,
                     [ "#!/usr/bin/env bash",
                       "guile -C \""
                         <> root
                         </> intdir
                         <> "\" -e main "
                         <> "-s "
                         <> Namespace.toPath namespace
                         <> " \"$@\""
                     ]
                       |> joinWith "\n"
                       |> Text.pack
                       |> Just
                   ),
            rundeps = prun,
            hsGraph = Nothing,
            ..
          }
          |> Just
          |> pure
    Namespace.Rs ->
      Meta.detectAll "//" contentLines |> \Meta.Parsed {..} ->
        Target
          { langdeps = pdep,
            -- this packageSet doesn't actually exist because everyone in
            -- nix just generates nix expressions for rust dependencies with
            -- Cargo.lock, so I have to make it in order to use rust deps
            packageSet = "rust.packages",
            mainModule = Namespace.toModule namespace,
            wrapper = Nothing,
            sysdeps = psys <> Set.singleton "rustc",
            out = pout <|> defaultOut,
            compiler = Rustc,
            compilerFlags = case pout of
              Just o ->
                map
                  Text.pack
                  [ "$CODEROOT" </> path,
                    "-o",
                    o
                  ]
              Nothing -> panic "can't build rust libs",
            builder = "base",
            outPath = outToPath pout,
            -- implement detectRustImports
            srcs = Set.empty,
            rundeps = prun,
            hsGraph = Nothing,
            ..
          }
          |> Just
          |> pure

detectHaskellImports :: Analysis -> [Text] -> IO (Set Meta.Dep, Set FilePath)
detectHaskellImports _ contentLines = do
  root <- getCoderoot
  let initialMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ contentLines))
  initialLocals <- toLocalFiles root initialMods
  let initialLocalsSet = Set.fromList initialLocals
  let localMods = [m | m <- initialMods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` initialLocals]
  let initialExternals = filter (`notElem` localMods) initialMods
  (srcs, transitiveExtMods) <- bfs root initialLocalsSet Set.empty Set.empty
  let allExtMods = Set.fromList initialExternals <> transitiveExtMods
  pkgSets <- Async.mapConcurrently ghcPkgFindModuleCached (Set.toList allExtMods)
  let pkgs = mconcat pkgSets
  pure (pkgs, srcs)
  where
    bfs :: FilePath -> Set FilePath -> Set FilePath -> Set String -> IO (Set FilePath, Set String)
    bfs root queue visited extMods
      | Set.null queue = pure (visited, extMods)
      | otherwise = do
          let (rel, queue') = Set.deleteFindMin queue
          fileLines <-
            withFile (root </> rel) ReadMode <| \h ->
              IO.hSetEncoding h IO.utf8_bom
                >> Text.IO.hGetContents h
                /> Text.lines
          let mods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines))
          locals <- toLocalFiles root mods
          let localsSet = Set.fromList locals
          let localModsFromPaths = Set.fromList [m | m <- mods, (Namespace.fromHaskellModule m |> Namespace.toPath) `elem` locals]
          let newExternals = Set.fromList mods Set.\\ localModsFromPaths
          let newLocals = localsSet Set.\\ visited
          bfs root (queue' <> newLocals) (Set.insert rel visited) (extMods <> newExternals)

    toLocalFiles :: FilePath -> [String] -> IO [FilePath]
    toLocalFiles root mods = do
      let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods
      filterM (\rel -> Dir.doesFileExist (root </> rel)) rels

stripRoot :: FilePath -> FilePath -> FilePath
stripRoot root f = fromMaybe f (List.stripPrefix (root <> "/") f)

detectLispImports :: [Text] -> IO (Set Meta.Dep)
detectLispImports contentLines =
  contentLines
    /> Text.unpack
    /> Regex.match lispRequires
    |> catMaybes
    |> Set.fromList
    |> pure

-- | Finds local imports and recursively finds transitive imports and langdeps.
-- Returns (srcs, transitive langdeps).
detectPythonImports :: Analysis -> [Text] -> IO (Set FilePath, Set Meta.Dep)
detectPythonImports _ contentLines = do
  root <- getCoderoot
  let initialMods = catMaybes (Regex.match pythonImport </ (Text.unpack </ contentLines))
  initialLocals <- toLocalFiles root initialMods
  bfs root (Set.fromList initialLocals) Set.empty Set.empty
  where
    -- only detects 'import x' because I don't like 'from'
    pythonImport :: Regex.RE Char String
    pythonImport =
      Regex.string "import"
        *> Regex.some (Regex.psym Char.isSpace)
        *> Regex.many (Regex.psym isModuleChar)
        <* Regex.many Regex.anySym

    bfs :: FilePath -> Set FilePath -> Set FilePath -> Set Meta.Dep -> IO (Set FilePath, Set Meta.Dep)
    bfs root queue visited deps
      | Set.null queue = pure (visited, deps)
      | otherwise = do
          let (rel, queue') = Set.deleteFindMin queue
          fileLines <-
            withFile (root </> rel) ReadMode <| \h ->
              IO.hSetEncoding h IO.utf8_bom
                >> Text.IO.hGetContents h
                /> Text.lines
          let mods = catMaybes (Regex.match pythonImport </ (Text.unpack </ fileLines))
          locals <- toLocalFiles root mods
          let localsSet = Set.fromList locals
          let newLocals = localsSet Set.\\ visited
          -- Collect langdeps from this file's metadata
          let Meta.Parsed {pdep = fileDeps} = Meta.detectAll "#" fileLines
          bfs root (queue' <> newLocals) (Set.insert rel visited) (deps <> fileDeps)

    toLocalFiles :: FilePath -> [String] -> IO [FilePath]
    toLocalFiles root mods = do
      let rels = map (Namespace.fromPythonModule .> Namespace.toPath) mods
      filterM (\rel -> Dir.doesFileExist (root </> rel)) rels

test_detectPythonImports :: Test.Tree
test_detectPythonImports =
  Test.group
    "detectPythonImports"
    [ Test.unit "matches import statements" <| do
        (srcs, _) <- detectPythonImports mempty ["import Omni.Log"]
        Set.fromList ["Omni/Log.py"] @=? srcs,
      Test.unit "matches import as statements" <| do
        (srcs, _) <- detectPythonImports mempty ["import Omni.Log as Log"]
        Set.fromList ["Omni/Log.py"] @=? srcs
    ]

test_buildHsModuleGraph :: Test.Tree
test_buildHsModuleGraph =
  Test.group
    "buildHsModuleGraph"
    [ Test.unit "includes entry point in graph" <| do
        let ns = Namespace ["Omni", "Bild", "Example"] Namespace.Hs
        let entryPoint = "Omni/Bild/Example.hs"
        let deps = Set.fromList ["Alpha.hs", "Omni/Test.hs"]

        result <- buildHsModuleGraph ns entryPoint deps
        case result of
          Nothing -> Test.assertFailure "buildHsModuleGraph returned Nothing"
          Just graph -> do
            let modules = Map.keys (graphModules graph)
            Text.pack "Omni.Bild.Example" `elem` modules @=? True
    ]

type GhcPkgCacheMem = Map String (Set String)

type GhcPkgCacheDisk = Map String [String]

{-# NOINLINE ghcPkgCache #-}
ghcPkgCache :: IORef GhcPkgCacheMem
ghcPkgCache = unsafePerformIO (newIORef Map.empty)

cacheToDisk :: GhcPkgCacheMem -> GhcPkgCacheDisk
cacheToDisk = Map.map Set.toList

cacheFromDisk :: GhcPkgCacheDisk -> GhcPkgCacheMem
cacheFromDisk = Map.map Set.fromList

ghcPkgCacheHash :: IO (Maybe String)
ghcPkgCacheHash = do
  mdb <- Env.lookupEnv "GHC_PACKAGE_PATH"
  case mdb of
    Nothing -> pure Nothing
    Just db -> do
      v <-
        Exception.catch
          ( Process.readProcess "ghc" ["--numeric-version"] ""
              /> takeWhile (/= '\n')
          )
          (\(_ :: Exception.SomeException) -> pure "")
      if null v then pure Nothing else pure (Just (hashString (v <> "|" <> db)))
  where
    hashString :: String -> String
    hashString s =
      List.foldl' (\h c -> h * 131 + fromEnum c) (7 :: Int) s
        |> abs
        |> toInteger
        |> \n -> Numeric.showHex n ""

ghcPkgCachePath :: IO (Maybe FilePath)
ghcPkgCachePath = do
  root <- getCoderoot
  fmap (\h -> root </> vardir </> ("ghc-pkg-cache-" <> h <> ".json")) </ ghcPkgCacheHash

loadGhcPkgCache :: IO ()
loadGhcPkgCache = do
  mpath <- ghcPkgCachePath
  case mpath of
    Nothing -> pure ()
    Just path -> do
      exists <- Dir.doesFileExist path
      if not exists
        then pure ()
        else do
          eres <- Exception.try (ByteString.Lazy.readFile path) :: IO (Either Exception.IOException ByteString.Lazy.ByteString)
          case eres of
            Left _ -> pure ()
            Right bs ->
              case Aeson.eitherDecode bs :: Either String GhcPkgCacheDisk of
                Left _ -> pure ()
                Right disk -> writeIORef ghcPkgCache (cacheFromDisk disk)

saveGhcPkgCache :: IO ()
saveGhcPkgCache = do
  mpath <- ghcPkgCachePath
  case mpath of
    Nothing -> pure ()
    Just path -> do
      cache <- readIORef ghcPkgCache
      let tmp = path <> ".tmp"
      Dir.createDirectoryIfMissing True (takeDirectory path)
      ByteString.Lazy.writeFile tmp (Aeson.encode (cacheToDisk cache))
      Dir.renameFile tmp path

ghcPkgFindModuleCached :: String -> IO (Set String)
ghcPkgFindModuleCached m = do
  cache <- readIORef ghcPkgCache
  case Map.lookup m cache of
    Just pkgs -> pure pkgs
    Nothing -> do
      pkgs <- ghcPkgFindModule Set.empty m
      modifyIORef' ghcPkgCache (Map.insert m pkgs)
      pure pkgs

ghcPkgFindModule :: Set String -> String -> IO (Set String)
ghcPkgFindModule acc m =
  Env.getEnv "GHC_PACKAGE_PATH" +> \packageDb ->
    Process.readProcess
      "ghc-pkg"
      ["--package-db", packageDb, "--names-only", "--simple-output", "find-module", m]
      ""
      /> String.lines
      /> Set.fromList
      /> Set.union acc

-- | Build module graph for Haskell targets, returns Nothing if TH or cycles detected
buildHsModuleGraph :: Namespace -> FilePath -> Set FilePath -> IO (Maybe HsModuleGraph)
buildHsModuleGraph namespace entryPoint deps = do
  root <- getCoderoot
  -- Analyze all dependencies first
  depNodes <- foldM (analyzeModule root) Map.empty (Set.toList deps)
  -- Then analyze the entry point itself
  allNodes <- analyzeModule root depNodes entryPoint
  let hasTH = any nodeHasTH (Map.elems allNodes)
  let hasCycles = detectCycles allNodes
  if hasTH || hasCycles
    then pure Nothing
    else
      pure
        <| Just
          HsModuleGraph
            { graphEntry = Namespace.toHaskellModule namespace |> Text.pack,
              graphModules = allNodes
            }
  where
    analyzeModule :: FilePath -> Map ModuleName HsModuleNode -> FilePath -> IO (Map ModuleName HsModuleNode)
    analyzeModule root acc srcPath = do
      let modName = pathToModuleName srcPath
      case Map.lookup modName acc of
        Just _ -> pure acc
        Nothing -> do
          fileLines <-
            withFile (root </> srcPath) ReadMode <| \h ->
              IO.hSetEncoding h IO.utf8_bom
                >> Text.IO.hGetContents h
                /> Text.lines
          let importedMods = catMaybes (Regex.match haskellImports </ (Text.unpack </ fileLines))
          localImportMods <- filterLocalImports root importedMods
          let hasTH = detectTH fileLines
          let node =
                HsModuleNode
                  { nodePath = srcPath,
                    nodeImports = map Text.pack localImportMods,
                    nodeHasTH = hasTH
                  }
          pure (Map.insert modName node acc)

    pathToModuleName :: FilePath -> ModuleName
    pathToModuleName fp =
      fp
        |> dropExtension
        |> map (\c -> if c == '/' then '.' else c)
        |> Text.pack

    filterLocalImports :: FilePath -> [String] -> IO [String]
    filterLocalImports root mods = do
      let rels = map (Namespace.fromHaskellModule .> Namespace.toPath) mods
      filterM (\rel -> Dir.doesFileExist (root </> rel)) rels
        /> map (\rel -> replaceExtension rel "" |> map (\c -> if c == '/' then '.' else c))

    detectTH :: [Text] -> Bool
    detectTH =
      any
        ( \line ->
            Text.isInfixOf "TemplateHaskell" line
              || Text.isInfixOf "$(" line
        )

    detectCycles :: Map ModuleName HsModuleNode -> Bool
    detectCycles nodes =
      let sccs = stronglyConnComp (map nodeToEdge (Map.toList nodes))
       in any isNonTrivialSCC sccs
      where
        nodeToEdge :: (ModuleName, HsModuleNode) -> (HsModuleNode, ModuleName, [ModuleName])
        nodeToEdge (name, node) = (node, name, nodeImports node)

        isNonTrivialSCC :: SCC HsModuleNode -> Bool
        isNonTrivialSCC (AcyclicSCC _) = False
        isNonTrivialSCC (CyclicSCC sccNodes) = length sccNodes > 1

isFailure :: Exit.ExitCode -> Bool
isFailure (Exit.ExitFailure _) = True
isFailure Exit.ExitSuccess = False

isSuccess :: Exit.ExitCode -> Bool
isSuccess Exit.ExitSuccess = True
isSuccess _ = False

test :: Bool -> Target -> IO (Exit.ExitCode, ByteString)
test loud Target {..} =
  getCoderoot
    +> \root -> case compiler of
      Ghc ->
        Proc
          { loud = loud,
            cmd = root </> outToPath out,
            args = ["test"],
            ns = namespace,
            onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed),
            onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success)
          }
          |> run
      CPython ->
        Proc
          { loud = loud,
            cmd = root </> outToPath out,
            args = ["test"],
            ns = namespace,
            onFailure = loud ?: (Log.fail ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Failed),
            onSuccess = loud ?: (Log.pass ["test", nschunk namespace] >> Log.br, LogC.updateLineState namespace LogC.Success)
          }
          |> run
      _ ->
        pure (Exit.ExitFailure 1, mempty)

build :: Bool -> Bool -> Int -> Int -> Analysis -> IO [Exit.ExitCode]
build andTest loud jobs cpus analysis = do
  root <- getCoderoot
  let targets = Map.elems analysis
  -- Build runs concurrently with --jobs parallelism
  -- LineManager is set up by caller (move), so we just update states here
  results <- mapConcurrentlyBounded jobs (buildTarget root) targets
  pure (map fst results)
  where
    buildTarget :: FilePath -> Target -> IO (Exit.ExitCode, ByteString)
    buildTarget root target@Target {..} = do
      LogC.updateLineState namespace LogC.Building
      result <- case compiler of
        CPython -> case out of
          Just _ ->
            nixBuild loud jobs cpus target
              +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r))
          Nothing ->
            pure (Exit.ExitSuccess, mempty)
        Gcc ->
          nixBuild loud jobs cpus target
        Ghc -> case out of
          Nothing -> pure (Exit.ExitSuccess, mempty)
          Just _ -> do
            result <- nixBuild loud jobs cpus target
            if andTest && (isSuccess <| fst result)
              then test loud target
              else pure result
        Guile -> do
          _ <- proc loud namespace (toNixFlag compiler) compilerFlags
          case wrapper of
            Nothing -> pure (Exit.ExitSuccess, mempty)
            Just content -> do
              writeFile (root </> outToPath out) content
              p <- Dir.getPermissions <| root </> outToPath out
              Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p)
              pure (Exit.ExitSuccess, mempty)
        NixBuild ->
          Dir.getPermissions quapath /> Dir.executable +> \isExe ->
            isExe
              ?: ( proc
                     loud
                     namespace
                     (toNixFlag compiler)
                     ( compilerFlags
                         ++ [ "--max-jobs",
                              Text.pack <| str jobs,
                              "--cores",
                              Text.pack <| str cpus
                            ]
                     ),
                   pure (Exit.ExitSuccess, mempty)
                 )
        Copy ->
          pure (Exit.ExitSuccess, mempty)
        Rustc ->
          nixBuild loud jobs cpus target
        Sbcl ->
          proc loud namespace (toNixFlag compiler) compilerFlags
      LogC.updateLineState namespace (isSuccess (fst result) ?: (LogC.Success, LogC.Failed))
      pure result

-- | Pipeline state machine for each target
data TargetState
  = TSQueued
  | TSAnalyzing
  | TSAnalysisFailed
  | TSWaitingForDeps Target (Set Namespace)
  | TSReadyToBuild Target
  | TSBuilding Target
  | TSComplete Target Exit.ExitCode

-- | Coordinator manages the pipelined analyze→build flow
data Coordinator = Coordinator
  { coStates :: TVar (Map Namespace TargetState),
    coAnalyzeQ :: TQueue Namespace,
    coBuildQ :: TQueue Namespace,
    coAllTargets :: Set Namespace,
    coResults :: TVar [Exit.ExitCode],
    coRemaining :: TVar Int,
    coRoot :: FilePath
  }

initCoordinator :: FilePath -> [Namespace] -> IO Coordinator
initCoordinator root nss =
  atomically <| do
    let allTargets = Set.fromList nss
    states <- newTVar (Map.fromList [(ns, TSQueued) | ns <- nss])
    analyzeQ <- newTQueue
    buildQ <- newTQueue
    results <- newTVar []
    remaining <- newTVar (length nss)
    forM_ nss (writeTQueue analyzeQ)
    pure
      Coordinator
        { coStates = states,
          coAnalyzeQ = analyzeQ,
          coBuildQ = buildQ,
          coAllTargets = allTargets,
          coResults = results,
          coRemaining = remaining,
          coRoot = root
        }

computeDeps :: Coordinator -> Target -> Set Namespace
computeDeps Coordinator {..} Target {..} =
  let toNs path = Namespace.fromPath coRoot (coRoot </> path)
      result =
        srcs
          |> Set.toList
          |> map toNs
          |> catMaybes
          |> Set.fromList
          |> flip Set.intersection coAllTargets
          |> Set.delete namespace
   in result

tsIsComplete :: TargetState -> Bool
tsIsComplete (TSComplete _ _) = True
tsIsComplete _ = False

pipelineAnalysisWorker :: Coordinator -> (Namespace -> IO (Maybe Target)) -> IO ()
pipelineAnalysisWorker coord@Coordinator {..} analyzeFn = loop
  where
    loop = do
      remaining <- readTVarIO coRemaining
      when (remaining > 0) <| do
        mNs <- atomically (tryReadTQueue coAnalyzeQ)
        case mNs of
          Nothing -> threadDelay 1000 >> loop
          Just ns -> do
            atomically <| modifyTVar' coStates (Map.insert ns TSAnalyzing)
            LogC.updateLineState ns LogC.Analyzing
            result <- analyzeFn ns
            case result of
              Nothing -> do
                atomically <| do
                  modifyTVar' coStates (Map.insert ns TSAnalysisFailed)
                  modifyTVar' coRemaining (subtract 1)
                LogC.updateLineState ns LogC.Failed
              Just target -> do
                let deps = computeDeps coord target
                atomically <| do
                  states <- readTVar coStates
                  let pendingDeps = Set.filter (\d -> maybe True (tsIsComplete .> not) (Map.lookup d states)) deps
                  if Set.null pendingDeps
                    then do
                      modifyTVar' coStates (Map.insert ns (TSReadyToBuild target))
                      writeTQueue coBuildQ ns
                    else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target pendingDeps))
            loop

pipelineBuildWorker :: Bool -> Bool -> Int -> Int -> Coordinator -> IO ()
pipelineBuildWorker andTest loud jobs cpus coord@Coordinator {..} = loop
  where
    loop = do
      remaining <- readTVarIO coRemaining
      when (remaining > 0) <| do
        mNs <- atomically (tryReadTQueue coBuildQ)
        case mNs of
          Nothing -> threadDelay 1000 >> loop
          Just ns -> do
            mTarget <-
              atomically <| do
                states <- readTVar coStates
                case Map.lookup ns states of
                  Just (TSReadyToBuild t) -> do
                    modifyTVar' coStates (Map.insert ns (TSBuilding t))
                    pure (Just t)
                  _ -> pure Nothing
            case mTarget of
              Nothing -> loop
              Just target -> do
                LogC.updateLineState ns LogC.Building
                exitCode <- pipelineBuildOne andTest loud jobs cpus target
                atomically <| do
                  modifyTVar' coStates (Map.insert ns (TSComplete target exitCode))
                  modifyTVar' coResults (exitCode :)
                  modifyTVar' coRemaining (subtract 1)
                  promoteWaiters coord ns
                LogC.updateLineState ns (isSuccess exitCode ?: (LogC.Success, LogC.Failed))
                loop

promoteWaiters :: Coordinator -> Namespace -> STM ()
promoteWaiters Coordinator {..} completedNs = do
  states <- readTVar coStates
  forM_ (Map.toList states) <| \(ns, st) ->
    case st of
      TSWaitingForDeps target deps -> do
        let deps' = Set.delete completedNs deps
        if Set.null deps'
          then do
            modifyTVar' coStates (Map.insert ns (TSReadyToBuild target))
            writeTQueue coBuildQ ns
          else modifyTVar' coStates (Map.insert ns (TSWaitingForDeps target deps'))
      _ -> pure ()

pipelineBuildOne :: Bool -> Bool -> Int -> Int -> Target -> IO Exit.ExitCode
pipelineBuildOne andTest loud jobs cpus target@Target {..} = do
  root <- getCoderoot
  result <- case compiler of
    CPython -> case out of
      Just _ ->
        nixBuild loud jobs cpus target
          +> (\r -> (isSuccess (fst r) && andTest) ?: (test loud target, pure r))
      Nothing ->
        pure (Exit.ExitSuccess, mempty)
    Gcc ->
      nixBuild loud jobs cpus target
    Ghc -> case out of
      Nothing -> pure (Exit.ExitSuccess, mempty)
      Just _ -> do
        r <- nixBuild loud jobs cpus target
        if andTest && (isSuccess <| fst r)
          then test loud target
          else pure r
    Guile -> do
      _ <- proc loud namespace (toNixFlag compiler) compilerFlags
      case wrapper of
        Nothing -> pure (Exit.ExitSuccess, mempty)
        Just content -> do
          writeFile (root </> outToPath out) content
          p <- Dir.getPermissions <| root </> outToPath out
          Dir.setPermissions (root </> outToPath out) (Dir.setOwnerExecutable True p)
          pure (Exit.ExitSuccess, mempty)
    NixBuild ->
      Dir.getPermissions quapath /> Dir.executable +> \isExe ->
        isExe
          ?: ( proc
                 loud
                 namespace
                 (toNixFlag compiler)
                 ( compilerFlags
                     ++ [ "--max-jobs",
                          Text.pack <| str jobs,
                          "--cores",
                          Text.pack <| str cpus
                        ]
                 ),
               pure (Exit.ExitSuccess, mempty)
             )
    Copy ->
      pure (Exit.ExitSuccess, mempty)
    Rustc ->
      nixBuild loud jobs cpus target
    Sbcl ->
      proc loud namespace (toNixFlag compiler) compilerFlags
  pure (fst result)

pipelineBuild :: Bool -> Bool -> Int -> Int -> Int -> [Namespace] -> (Namespace -> IO (Maybe Target)) -> IO [Exit.ExitCode]
pipelineBuild andTest loud analysisWorkers buildWorkers cpus namespaces analyzeFn = do
  root <- getCoderoot
  coord <- initCoordinator root namespaces
  let spawnAnalysis = replicateM analysisWorkers (Async.async (pipelineAnalysisWorker coord analyzeFn))
  let spawnBuild = replicateM buildWorkers (Async.async (pipelineBuildWorker andTest loud buildWorkers cpus coord))
  threads <- (<>) </ spawnAnalysis <*> spawnBuild
  let waitLoop = do
        remaining <- readTVarIO (coRemaining coord)
        if remaining == 0
          then pure ()
          else do
            threadDelay 10000
            waitLoop
  waitLoop
  traverse_ Async.cancel threads
  readTVarIO (coResults coord)

data Proc = Proc
  { loud :: Bool,
    cmd :: String,
    args :: [String],
    ns :: Namespace,
    onFailure :: IO (),
    onSuccess :: IO ()
  }

-- | Convert minutes to milliseconds.
toMillis :: (Num a) => a -> a
toMillis mins = mins * 60_000_000

-- | Run a subprocess, streaming output if --loud is set.
run :: Proc -> IO (Exit.ExitCode, ByteString)
run Proc {..} = do
  IO.hSetBuffering stdout IO.NoBuffering
  loud ?| Log.info ["proc", unwords <| map str <| cmd : args]
  Conduit.proc cmd args
    |> (\proc_ -> proc_ {Process.create_group = True})
    |> Conduit.streamingProcess
    +> \(stdin_, stdout_, stderr_, hdl) -> do
      IO.hClose stdin_ -- Close stdin immediately since we don't use it
      (,,)
        </ Async.Concurrently (Conduit.waitForStreamingProcess hdl)
        <*> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_))
        <*> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_))
        |> Async.runConcurrently
        +> \case
          (Exit.ExitFailure n, output, outerr) ->
            Conduit.closeStreamingProcessHandle hdl
              >> putStr outerr
              >> onFailure
              >> pure (Exit.ExitFailure n, output)
          (Exit.ExitSuccess, output, _) ->
            Conduit.closeStreamingProcessHandle hdl
              >> onSuccess
              >> pure (Exit.ExitSuccess, output)

-- | Helper for running a standard bild subprocess.
proc ::
  Bool ->
  Namespace ->
  String ->
  [Text] ->
  IO (Exit.ExitCode, ByteString)
proc loud namespace cmd args =
  Proc
    { loud = loud,
      ns = namespace,
      cmd = cmd,
      args = map Text.unpack args,
      onFailure = Log.fail ["bild", nschunk namespace] >> Log.br,
      onSuccess = pure ()
    }
    |> run

-- | Helper for printing during a subprocess
puts ::
  Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () ->
  IO ByteString
puts src =
  Conduit.runConduitRes
    <| src
    .| Conduit.iterM (liftIO <. putStr)
    .| Conduit.foldC

-- | Like 'puts' but logs the output via 'Omni.Log'.
logs ::
  Namespace ->
  Conduit.ConduitT () ByteString (Conduit.ResourceT IO) () ->
  IO ByteString
logs ns src =
  Env.lookupEnv "COLUMNS"
    -- is there a better way to set a default?
    /> maybe 79 (readMaybe .> fromMaybe 79)
    +> \columns ->
      src
        .| Conduit.iterM
          ( ByteString.filter (/= BSI.c2w '\n')
              .> decodeUtf8
              .> Text.take (columns - 1)
              .> (<> "...")
              .> LogC.updateLine ns
              .> liftIO
          )
        .| Conduit.foldC
        |> Conduit.runConduitRes

nschunk :: Namespace -> Text
nschunk = Namespace.toPath .> Text.pack

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

isModuleChar :: Char -> Bool
isModuleChar c =
  elem c <| concat [['A' .. 'Z'], ['a' .. 'z'], ['.', '_'], ['0' .. '9']]

-- | Matches on `(require :package)` forms and returns `package`. The `require`
-- function is technically deprecated in Common Lisp, but no new spec has been
-- published with a replacement, and I don't wanna use asdf, so this is what we
-- use for Lisp imports.
lispRequires :: Regex.RE Char String
lispRequires =
  Regex.string "(require"
    *> Regex.some (Regex.psym Char.isSpace)
    *> Regex.many (Regex.psym isQuote)
    *> Regex.many (Regex.psym isModuleChar)
    <* Regex.many (Regex.psym (== ')'))
  where
    isQuote :: Char -> Bool
    isQuote c = c `elem` ['\'', ':']

nixBuild :: Bool -> Int -> Int -> Target -> IO (Exit.ExitCode, ByteString)
nixBuild loud maxJobs cores target@(Target {..}) =
  getCoderoot +> \root ->
    instantiate root |> run +> \case
      (_, "") -> panic "instantiate did not produce a drv"
      (Exit.ExitSuccess, drv) ->
        drv
          |> str
          |> chomp
          |> str
          |> realise
          |> run
          +> \case
            (Exit.ExitSuccess, _) -> run symlink
            failure -> pure failure
      x -> pure x
  where
    instantiate root =
      Proc
        { loud = loud,
          ns = namespace,
          cmd = "nix-instantiate",
          -- 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", "analysisJSON", str <| Aeson.encode <| (Map.singleton namespace target :: Analysis)],
              ["--arg", "bild", str <| "import " <> root </> "Omni/Bild.nix {}"],
              [str <| root </> "Omni/Bild/Builder.nix"]
            ]
              |> mconcat
              |> map Text.unpack,
          onFailure = Log.fail ["bild", "instantiate", nschunk namespace] >> Log.br,
          onSuccess = pure ()
        }
    realise drv =
      Proc
        { loud = loud,
          ns = namespace,
          cmd = "nix-store",
          args =
            [ "--realise",
              drv,
              "--add-root",
              nixdir </> outname out,
              "--max-jobs",
              str maxJobs,
              "--cores",
              str cores
            ],
          onFailure = Log.fail ["bild", "realise", nschunk namespace] >> Log.br,
          onSuccess = pure ()
        }
    symlink =
      Proc
        { loud = loud,
          ns = namespace,
          cmd = "ln",
          args =
            [ "--relative",
              "--force",
              "--symbolic",
              nixdir </> outname out </> "bin" </> outname out,
              bindir </> outname out
            ],
          onFailure = Log.fail ["bild", "symlink", nschunk namespace] >> Log.br,
          onSuccess = pure ()
        }

getCoderoot :: IO FilePath
getCoderoot = do
  mEnvRoot <- Env.lookupEnv "CODEROOT"
  cwd <- Dir.getCurrentDirectory
  case mEnvRoot of
    Just envRoot -> do
      let isPrefix = envRoot `List.isPrefixOf` cwd
      let validPrefix =
            isPrefix
              && ( length envRoot
                     == length cwd
                     || (length cwd > length envRoot && (List.!!) cwd (length envRoot) == '/')
                 )
      if validPrefix
        then pure envRoot
        else do
          mRealRoot <- findRoot cwd
          case mRealRoot of
            Just realRoot -> pure realRoot
            Nothing -> pure envRoot
    Nothing -> do
      mRealRoot <- findRoot cwd
      case mRealRoot of
        Just realRoot -> pure realRoot
        Nothing -> panic "CODEROOT not set and could not find root"

findRoot :: FilePath -> IO (Maybe FilePath)
findRoot dir = do
  let marker = dir </> "Omni"
  exists <- Dir.doesDirectoryExist marker
  if exists
    then pure (Just dir)
    else do
      let parent = takeDirectory dir
      if parent == dir
        then pure Nothing
        else findRoot parent