diff options
Diffstat (limited to 'Biz/Bild.hs')
| -rw-r--r-- | Biz/Bild.hs | 322 |
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']] |