diff options
Diffstat (limited to 'Biz/Bild.hs')
| -rw-r--r-- | Biz/Bild.hs | 163 |
1 files changed, 71 insertions, 92 deletions
diff --git a/Biz/Bild.hs b/Biz/Bild.hs index 96203a4..f0b829d 100644 --- a/Biz/Bild.hs +++ b/Biz/Bild.hs @@ -109,7 +109,6 @@ import qualified Biz.Cli as Cli import qualified Biz.Log as Log import Biz.Namespace (Namespace (..)) import qualified Biz.Namespace as Namespace -import Biz.Test ((@?=)) import qualified Biz.Test as Test import qualified Conduit import qualified Control.Concurrent.Async as Async @@ -127,7 +126,6 @@ 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 NeatInterpolation import qualified System.Directory as Dir import qualified System.Environment as Env import qualified System.Exit as Exit @@ -156,7 +154,6 @@ main = Cli.main <| Cli.Plan help move test_ pure Test.assertFailure "can't bild bild" _ -> pure () - -- test_toNixExpr ] move :: Cli.Arguments -> IO () @@ -266,40 +263,6 @@ data Target = Target } deriving (Show, Generic, Aeson.ToJSON) -toNixExpr :: String -> Target -> Text -toNixExpr root (Target {..}) = - [NeatInterpolation.trimming| -with import $troot/Biz/Bild.nix {}; -with builtins; -let - skip = ["_" ".direnv"]; - filter = name: type: - if elem (baseNameOf name) skip then false - # TODO: this means any new directory will cause a rebuild. this bad. - # i should recurse into the directory and match against the srcFiles - else if type == "directory" then true - else if type == "regular" then builtins.elem name [$srcFiles] - else false; -in stdenv.mkDerivation { - name = "$outname_"; - src = lib.sources.cleanSourceWith {inherit filter; src = lib.sources.cleanSource ./.;}; - buildInputs = [ (private.ghcWith (p: with p; [$nixLangdeps])) ]; - buildPhase = "$compilerCommand $compilerArgs"; - installPhase = "mkdir -p $$out/bin && cp $outname_ $$out/bin"; -}|] - where - troot, compilerCommand, compilerArgs, nixLangdeps, outname_, srcFiles :: Text - troot = Text.pack root - compilerCommand = compilerExe compiler - compilerArgs = str <| unwords compilerFlags - nixLangdeps = str <| String.unwords <| Set.toList langdeps - outname_ = str <| outname out - srcFiles = - ((root </> path) : Set.toList srcs) - |> map (\p -> "\"" <> p <> "\"\n") - |> String.unwords - |> str - -- | Use this to just get a target to play with at the repl. dev_getTarget :: IO Target dev_getTarget = do @@ -315,16 +278,6 @@ dev_getTarget = do Nothing -> panic "Could not retrieve target from analysis" Just t -> t -test_toNixExpr :: Test.Tree -test_toNixExpr = - Test.group - "toNixExpr" - [ Test.unit "produces corect result" <| do - root <- Env.getEnv "BIZ_ROOT" - t <- dev_getTarget - toNixExpr root t @?= [NeatInterpolation.trimming|TODO|] - ] - data Builder = -- | Local <user> Local Text @@ -489,37 +442,39 @@ analyze hmap ns = case Map.lookup ns hmap of |> Just |> pure Namespace.Hs -> - Meta.detectOut (Meta.out "--") contentLines |> \out -> do - (langdeps, srcs) <- detectHaskellImports hmap contentLines - Target - { builder = Local user, - wrapper = Nothing, - compiler = Ghc, - compilerFlags = - [ "-Werror", - "-i$src", - "-odir", - ".", - "-hidir", - ".", - "--make", - "$src" </> path - ] - ++ case out of - Meta.Bin o -> - [ "-main-is", - Namespace.toHaskellModule namespace, - "-o", - o - ] - _ -> [] - |> map Text.pack, - sysdeps = Meta.detect (Meta.sys "--") contentLines, - outPath = outToPath out, - .. - } - |> Just - |> pure + contentLines + |> Meta.detectOut (Meta.out "--") + |> \out -> + detectHaskellImports hmap contentLines +> \(langdeps, srcs) -> + Target + { builder = Local user, + wrapper = Nothing, + compiler = Ghc, + compilerFlags = + [ "-Werror", + "-i$src", + "-odir", + ".", + "-hidir", + ".", + "--make", + "$src" </> path + ] + ++ case out of + Meta.Bin o -> + [ "-main-is", + Namespace.toHaskellModule namespace, + "-o", + o + ] + _ -> [] + |> 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 @@ -628,10 +583,13 @@ detectHaskellImports hmap contentLines = |> catMaybes |> \imports -> foldM ghcPkgFindModule Set.empty imports - +> \pkgs -> do - a <- filepaths imports - b <- deps root imports - pure (b <> pkgs, Set.fromList a) + +> \pkgs -> + filepaths imports + +> \files -> + findDeps root files + +> \deps -> + (pkgs <> deps, Set.fromList files) + |> pure where filepaths :: [String] -> IO [FilePath] filepaths imports = @@ -640,20 +598,22 @@ detectHaskellImports hmap contentLines = |> map Namespace.toPath |> traverse Dir.makeAbsolute +> filterM Dir.doesFileExist - deps :: String -> [String] -> IO (Set Meta.Dep) - deps root imports = - filepaths imports - +> traverse (pure <. Namespace.fromPath root) + findDeps :: String -> [FilePath] -> IO (Set Meta.Dep) + findDeps root fps = + fps + |> traverse (pure <. 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 + +> foldM analyze (onlyHaskell hmap) /> Map.elems /> map langdeps /> mconcat + onlyHaskell :: Analysis -> Analysis + onlyHaskell = Map.filterWithKey (\ns _ -> ext ns == Namespace.Hs) detectLispImports :: [Text] -> IO (Set Meta.Dep) detectLispImports contentLines = @@ -761,7 +721,8 @@ data Proc = Proc -- | Run a subprocess, streaming output if --loud is set. run :: Proc -> IO (Exit.ExitCode, ByteString) -run Proc {..} = +run Proc {..} = do + loud ?| Log.info ["proc", unwords <| map str <| cmd : args] >> Log.br Conduit.proc cmd args |> Conduit.streamingProcess +> \(Conduit.UseProvidedHandle, stdout_, stderr_, hdl) -> @@ -769,8 +730,6 @@ run Proc {..} = +> \output -> Async.Concurrently (loud ?: (puts stdout_, logs ns stdout_)) *> Async.Concurrently (loud ?: (puts stderr_, logs ns stderr_)) - *> Async.Concurrently (putsToTmp stdout_ "/tmp/bild-log.out") - *> Async.Concurrently (putsToTmp stderr_ "/tmp/bild-log.err") *> Async.Concurrently (Conduit.waitForStreamingProcess hdl) |> Async.runConcurrently +> \case @@ -848,7 +807,7 @@ lispRequires = isQuote c = c `elem` ['\'', ':'] nixBuild :: Bool -> Target -> IO (Exit.ExitCode, ByteString) -nixBuild loud target@(Target {..}) = +nixBuild loud Target {..} = Env.getEnv "BIZ_ROOT" +> \root -> instantiate root |> run +> \case (Exit.ExitSuccess, drv) -> @@ -861,12 +820,32 @@ nixBuild loud target@(Target {..}) = >> run symlink x -> pure x where + argstr :: Text -> Text -> [Text] + argstr n v = ["--argstr", n, v] instantiate root = Proc { loud = loud, ns = namespace, cmd = "nix-instantiate", - args = map Text.unpack ["--expr", toNixExpr root target], + -- 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 "srcs" <| unwords <| map str <| (root </> path) : Set.toList srcs, + argstr "root" <| str root, + argstr "packageSet" "ghcWith" + ] + ++ (langdeps == mempty) + ?: ( [], + [argstr "langDeps" <| unwords <| map str <| Set.toList langdeps] + ) + ++ [ argstr "name" <| str <| outname out, + argstr "main" <| str path, + argstr "mainIs" <| str <| Namespace.toHaskellModule namespace, + [str <| root </> "Biz/Bild/Haskell.nix"] + ] + |> mconcat + |> map Text.unpack, onFailure = Log.fail ["bild", "instantiate", nschunk namespace] >> Log.br, onSuccess = pure () } |