Completes the prototype implementation of Bazel persistent worker mod…

…e support in rules_haskell

Started in 132d0af. This commit imports worker's code and sets everything to make
the persistent worker mode available to a regular `rules_haskell` user.

The worker code lives in `tools/worker`.

The mode is supported in ghc_nixpkgs-toolchain only, at this point.

WORKSPACE

@@ -79,6 +79,11 @@ stack_snapshot(
     deps = ["@zlib.dev//:zlib"],
 )
 
+# tools dependencies
+load("//tools:repositories.bzl", "rules_haskell_tools_dependencies")
+
+rules_haskell_tools_dependencies()
+
 load(
     "@io_tweag_rules_nixpkgs//nixpkgs:nixpkgs.bzl",
     "nixpkgs_cc_configure",

docs/haskell-use-cases.rst

@@ -337,3 +337,24 @@ There a couple of notes regarding the coverage analysis functionality:
   ``build`` / ``test`` performance.
 
 .. _hpc: https://hackage.haskell.org/package/hpc
+
+Persistent Worker Mode (experimental)
+-------------------------------------
+
+Bazel supports the special [persistent worker mode](https://blog.bazel.build/2015/12/10/java-workers.html) when instead of calling the compiler from scratch to build every target separately, it spawns a resident process for this purpose and sends all compilation requests to it in the client-server fashion. This worker strategy may improve compilation times. We implemented a worker for GHC using GHC API.
+
+To activate the persistent worker mode in ``rules_haskell`` the user adds a couple of lines in the ``WORKSPACE`` file. First, for the toolchain selection: ::
+
+  haskell_register_ghc_nixpkgs(
+      version = "X.Y.Z",
+      attribute_path = "ghc",
+      repositories = {"nixpkgs": "@nixpkgs"},
+      use_worker = True, # activate the persistent worker mode
+  )
+
+Second, for the worker dependencies: ::
+
+  load("//tools:repositories.bzl", "rules_haskell_tools_dependencies")
+  rules_haskell_tools_dependencies()
+
+It is worth noting that Bazel's worker strategy is not sandboxed by default. This may confuse our worker relatively easily. Therefore, it is recommended to supply ``--worker_sandboxing`` to ``bazel build`` -- possibly, via your ``.bazelrc.local`` file.

haskell/defs.bzl

@@ -91,6 +91,12 @@ _haskell_common_attrs = {
         cfg = "host",
         default = Label("@rules_haskell//haskell:ghc_wrapper"),
     ),
+    "_worker": attr.label(
+        default = Label("@rules_haskell//tools/worker:bin"),
+        executable = True,
+        cfg = "host",
+        doc = "Experimental. Worker binary employed by Bazel's persistent worker mode.",
+    ),
 }
 
 def _mk_binary_rule(**kwargs):

haskell/nixpkgs.bzl

@@ -183,6 +183,7 @@ def haskell_register_ghc_nixpkgs(
     Args:
       use_worker: This is a part of experimental support for the persistent worker mode.
         It is not intended for production usage, yet.
+        See docs/haskell-use-cases.rst for details.  
 
     Toolchains can be used to compile Haskell code. To have this
     toolchain selected during [toolchain

haskell/private/cabal_wrapper.sh.tpl

@@ -95,7 +95,7 @@ cd - >/dev/null
 # There were plans for controlling this, but they died. See:
 # https://github.com/haskell/cabal/pull/3982#issuecomment-254038734
 library=($libdir/libHS*.a)
-if [[ -n ${library+x} ]]
+if [[ -n ${library+x} && -f $package_database/$name.conf ]]
 then
     mv $libdir/libHS*.a $dynlibdir
     sed 's,library-dirs:.*,library-dirs: ${pkgroot}/lib,' \

haskell/private/context.bzl

@@ -40,13 +40,18 @@ def haskell_context(ctx, attr = None):
     if hasattr(ctx.executable, "_ghc_wrapper"):
         ghc_wrapper = ctx.executable._ghc_wrapper
 
+    worker = None
+    if hasattr(ctx.executable, "_worker"):
+        worker = ctx.executable._worker
+
     return HaskellContext(
         # Fields
         name = attr.name,
         label = ctx.label,
         toolchain = toolchain,
         tools = toolchain.tools,
         ghc_wrapper = ghc_wrapper,
+        worker = worker,
         package_ids = package_ids,
         src_root = src_root,
         package_root = ctx.label.workspace_root + ctx.label.package,

haskell/private/ghc_wrapper.sh

@@ -8,10 +8,9 @@ while IFS= read -r line; do compile_flags+=("$line"); done < $1
 
 # Detect if we are in the persistent worker mode
 if [ "$2" == "--persistent_worker" ]; then
-    compile_flags=("${compile_flags[@]:1}")  # remove ghc executable
-    # This is a proof-of-concept implementation, not ready for production usage:
-    # it assumes https://github.com/tweag/bazel-worker/ installed globally as ~/bin/worker
-    exec ~/bin/worker ${compile_flags[@]} --persistent_worker
+    # This runs our proof-of-concept implementation of a persistent worker
+    # wrapping GHC. Not ready for production usage.
+    exec ${compile_flags[@]} --persistent_worker
 else
     while IFS= read -r line; do extra_args+=("$line"); done < "$2"
     "${compile_flags[@]}" "${extra_args[@]}" 2>&1 \

haskell/protobuf.bzl

@@ -174,6 +174,7 @@ def _haskell_proto_aspect_impl(target, ctx):
         executable = struct(
             _ls_modules = ctx.executable._ls_modules,
             _ghc_wrapper = ctx.executable._ghc_wrapper,
+            _worker = ctx.executable._worker,
         ),
         # Necessary for CC interop (see cc.bzl).
         features = ctx.rule.attr.features,
@@ -245,6 +246,12 @@ _haskell_proto_aspect = aspect(
             cfg = "host",
             default = Label("@rules_haskell//haskell:ghc_wrapper"),
         ),
+        "_worker": attr.label(
+            default = Label("@rules_haskell//tools/worker:bin"),
+            executable = True,
+            cfg = "host",
+            doc = "Experimental. Worker binary employed by Bazel's persistent worker mode.",
+        ),
     },
     toolchains = [
         "@rules_haskell//haskell:toolchain",

haskell/toolchain.bzl

@@ -23,7 +23,20 @@ def _run_ghc(hs, cc, inputs, outputs, mnemonic, arguments, params_file = None, e
         env = hs.env
 
     args = hs.actions.args()
-    args.add(hs.tools.ghc)
+    extra_inputs = []
+
+    # Detect persistent worker support
+    flagsfile_prefix = ""
+    execution_requirements = {}
+    tools = []
+    if hs.toolchain.use_worker:
+        flagsfile_prefix = "@"
+        execution_requirements = {"supports-workers": "1"}
+        args.add(hs.worker.path)
+        tools = [hs.worker]
+    else:
+        args.add(hs.tools.ghc)
+        extra_inputs += [hs.tools.ghc]
 
     # Do not use Bazel's CC toolchain on Windows, as it leads to linker and librarty compatibility issues.
     # XXX: We should also tether Bazel's CC toolchain to GHC's, so that we can properly mix Bazel-compiled
@@ -57,8 +70,7 @@ def _run_ghc(hs, cc, inputs, outputs, mnemonic, arguments, params_file = None, e
     hs.actions.write(compile_flags_file, args)
     hs.actions.write(extra_args_file, arguments)
 
-    extra_inputs = [
-        hs.tools.ghc,
+    extra_inputs += [
         compile_flags_file,
         extra_args_file,
     ] + cc.files
@@ -73,15 +85,9 @@ def _run_ghc(hs, cc, inputs, outputs, mnemonic, arguments, params_file = None, e
     else:
         inputs += extra_inputs
 
-    # Detect persistent worker support
-    flagsfile_prefix = ""
-    execution_requirements = {}
-    if hs.toolchain.use_worker:
-        flagsfile_prefix = "@"
-        execution_requirements = {"supports-workers": "1"}
-
     hs.actions.run(
         inputs = inputs,
+        tools = tools,
         input_manifests = input_manifests,
         outputs = outputs,
         executable = hs.ghc_wrapper,

tests/haskell_proto_library/BUILD.bazel

@@ -76,6 +76,7 @@ haskell_library(
         ":person_haskell_proto",
         ":stripped_address_haskell_proto",
         "//tests/hackage:base",
+        "@stackage//:proto-lens",
     ],
 )
 

tests/haskell_proto_library/Bar.hs

@@ -4,5 +4,10 @@ import Proto.StrippedAddress
 import Proto.Tests.HaskellProtoLibrary.Person
 import Proto.Tests.HaskellProtoLibrary.Person_Fields
 
+import Data.ProtoLens.Message
+
+defPerson :: Person
+defPerson = defMessage
+
 bar :: Int
 bar = 5

tools/repositories.bzl

@@ -0,0 +1,29 @@
+"""Workspace rules (tools/repositories)"""
+
+load("@rules_haskell//haskell:cabal.bzl", "stack_snapshot")
+
+def rules_haskell_tools_dependencies():
+    """Provide all repositories that are necessary for `rules_haskell`'s tools to
+    function.
+    """
+    excludes = native.existing_rules().keys()
+
+    if "rules_haskell_worker_dependencies" not in excludes:
+        stack_snapshot(
+            name = "rules_haskell_worker_dependencies",
+            packages = [
+                "base",
+                "bytestring",
+                "filepath",
+                "ghc",
+                "ghc-paths",
+                "microlens",
+                "process",
+                "proto-lens",
+                "proto-lens-runtime",
+                "text",
+                "vector",
+            ],
+            snapshot = "lts-14.1",
+        )
+

tools/worker/BUILD.bazel

@@ -0,0 +1,20 @@
+load("@rules_haskell//haskell:cabal.bzl", "haskell_cabal_binary")
+
+haskell_cabal_binary(
+    name = "bin",
+    srcs = glob(["**"]),
+    visibility = ["//visibility:public"],
+    deps = [
+        "@rules_haskell_worker_dependencies//:base",
+        "@rules_haskell_worker_dependencies//:bytestring",
+        "@rules_haskell_worker_dependencies//:filepath",
+        "@rules_haskell_worker_dependencies//:ghc",
+        "@rules_haskell_worker_dependencies//:ghc-paths",
+        "@rules_haskell_worker_dependencies//:microlens",
+        "@rules_haskell_worker_dependencies//:process",
+        "@rules_haskell_worker_dependencies//:proto-lens",
+        "@rules_haskell_worker_dependencies//:proto-lens-runtime",
+        "@rules_haskell_worker_dependencies//:text",
+        "@rules_haskell_worker_dependencies//:vector",
+    ],
+)

tools/worker/Compile.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+
+module Compile (compile) where
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Data.List
+import System.FilePath
+import System.Exit
+
+import GHC
+import GHC.Paths ( libdir )
+import DynFlags ( defaultFatalMessager, defaultFlushOut, Option(..) )
+import DriverPhases
+import DriverPipeline ( compileFile, oneShot )
+import Util
+
+compile :: [String] -> IO ()
+compile flags =
+    defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+      runGhc (Just libdir) $ do
+
+        -- Parse flags
+        dflags <- getSessionDynFlags
+        (dflags2, fileish_args, _warns) <-
+          parseDynamicFlags dflags (map noLoc flags)
+
+        -- Normilize paths
+        let
+          normalise_hyp fp
+            | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
+            | otherwise                           = nfp
+            where
+-- # if defined(mingw32_HOST_OS) -- TODO: do we need Win support at this point?
+--          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
+-- # else
+              strt_dot_sl = "./" `isPrefixOf` fp
+-- # endif
+              cur_dir = '.' : [pathSeparator]
+              nfp = normalise fp
+          normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
+          (srcs, objs)         = partition_args normal_fileish_paths [] []
+
+        -- Update flags with normalized
+          dflags3 = dflags2 { ldInputs = map (FileOption "") objs
+                                         ++ ldInputs dflags2 }
+
+        _ <- setSessionDynFlags dflags3
+
+        doMake srcs
+
+doMake :: [(String,Maybe Phase)] -> Ghc ()
+doMake srcs  = do
+    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
+
+    hsc_env <- GHC.getSession
+
+    -- if we have no haskell sources from which to do a dependency
+    -- analysis, then just do one-shot compilation and/or linking.
+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+    -- we expect.
+    if (null hs_srcs)
+       then liftIO (oneShot hsc_env StopLn srcs)
+       else do
+
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+                 non_hs_srcs
+    dflags <- GHC.getSessionDynFlags
+    let dflags' = dflags { ldInputs = map (FileOption "") o_files
+                                      ++ ldInputs dflags }
+    _ <- GHC.setSessionDynFlags dflags'
+
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load LoadAllTargets
+
+    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+    return ()
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || "-" `isPrefixOf` m
+                      || not (hasExtension m)

tools/worker/Main.hs

@@ -0,0 +1,28 @@
+module Main where
+
+import Server (server)
+
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+import System.IO
+
+--import GHC.IO.Handle (hDuplicate, hDuplicateTo)
+
+pwFlag :: String
+pwFlag = "--persistent_worker"
+
+main :: IO ()
+main = do
+
+    -- redirect stdout to stderr
+    -- stdout_dup <- hDuplicate stdout
+    -- hDuplicateTo stderr stdout
+    let stdout_dup = stdout
+
+    args <- getArgs
+    hPutStrLn stderr $ "Args taken: " ++ show args    
+    if pwFlag `elem` args
+      then server stdin stdout_dup $ filter (/= pwFlag) args
+      else
+          print "Worker should be called with --persistent_worker"
+          >> exitFailure