WIP optparse

Change-Id: Iea0d9564cac03be98281b3eb2c79409cd88dcea2

Author: tek

buck-proxy/lib/BuckProxy/Orchestration.hs

@@ -37,7 +37,7 @@ import System.Directory (createDirectoryIfMissing)
 import System.Exit (exitFailure)
 import System.Process (ProcessHandle, getProcessExitCode, spawnProcess)
 import Types.Args (TargetId)
-import Types.BuckArgs (BuckArgs (workerTargetId), parseBuckArgs)
+import Types.BuckArgs (BuckArgs (workerTargetId), parseBuckArgsCli)
 import Types.Grpc (CommandEnv (..), RequestArgs (..))
 import Types.Orchestration (
   PrimarySocketName (..),
@@ -87,7 +87,7 @@ proxyHandler workerMap command socketDefault socketOverride req = do
       -- from the gRPC socket path if the key is absent from the env.
       -- If an override was specified on the command line with @--socket-name@, it has precedence over both.
       socketId = fromMaybe socketDefault (socketOverride <|> coerce (cmdEnv.values !? "BUCK_BUILD_ID"))
-  buckArgs <- either (throwIO . userError) pure (parseBuckArgs cmdEnv (RequestArgs argv))
+  buckArgs <- either (throwIO . userError) pure (parseBuckArgsCli cmdEnv (RequestArgs argv))
   case buckArgs.workerTargetId of
     Nothing -> throwIO (userError "No --worker-target-id passed")
     Just targetId -> do

ghc-proxy/app/ghc-proxy/Main.hs

@@ -11,14 +11,14 @@ import System.Environment (getArgs, lookupEnv)
 import System.Exit (exitFailure)
 import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, stderr, stdout)
 import Types.Args (Args (..))
-import Types.BuckArgs (parseBuckArgs, toGhcArgs)
+import Types.BuckArgs (parseBuckArgsCli, toGhcArgs)
 import Types.Env (Env (..))
 import Types.Grpc (CommandEnv (..), RequestArgs (..))
 import Types.Log (Log, Logger (..), TraceId (..), newLog)
 
 envFromArgs :: [String] -> IO (Env, MVar Log)
 envFromArgs argv = do
-  buckArgs <- either parseError pure (parseBuckArgs (CommandEnv []) (RequestArgs argv))
+  buckArgs <- either parseError pure (parseBuckArgsCli (CommandEnv []) (RequestArgs argv))
   args <- toGhcArgs buckArgs Nothing
   actionMetadata <- lookupEnv "ACTION_METADATA"
   let args' = args {actionMetadata}

ghc-server/lib/GhcClient/Run.hs

@@ -40,14 +40,15 @@ import System.IO (BufferMode (..), hPutStrLn, hSetBuffering, stderr, stdout)
 import System.OsPath (encodeUtf)
 
 -- | CLI argument parser for the client.
+--
+-- Parses only client-local options (@--wait@) and the project root.
+-- All remaining arguments (after @--@) are passed verbatim to the server.
 clientConfigParser :: Parser ClientConfig
 clientConfigParser = do
   projectRoot <- argument readOsPath (metavar "PROJECT_ROOT" <> help "Path to the project root directory")
   wait <- switch (long "wait" <> short 'w' <> help "Wait for the build to complete before returning")
-  recompile <- switch (long "recompile" <> help "Recompile modules even when cached artifacts exist")
-  rebuild <- switch (long "rebuild" <> help "Recompute metadata and recompile even when cached")
-  targets <- many (strArgument (metavar "TARGETS..." <> help "Schedule targets (e.g. unit1 unit2:metadata unit2:Module)"))
-  pure ClientConfig {..}
+  targets <- many (strArgument (metavar "ARGS..." <> help "Arguments passed verbatim to the server (use -- to pass flags)"))
+  pure ClientConfig {projectRoot, wait, targets}
   where
     readOsPath =
       eitherReader (first show <$> encodeUtf)
@@ -78,8 +79,6 @@ client config = do
 
     flagArgs =
       ["--wait" | config.wait]
-      ++ ["--recompile" | config.recompile]
-      ++ ["--rebuild" | config.rebuild]
 
 -- | Parse CLI args and run the client command.
 runClient :: IO ()

ghc-server/lib/GhcServer/Data/Config.hs

@@ -25,13 +25,9 @@ data ClientConfig =
   ClientConfig {
     -- | Absolute path to the project root directory.
     projectRoot :: OsPath,
-    -- | Raw schedule arguments to send.
+    -- | Raw arguments to send to the server, including schedule targets and flags like @--recompile@/@--rebuild@.
     targets :: [String],
     -- | Whether to wait for the build to complete before returning.
-    wait :: Bool,
-    -- | Force recompilation of modules even when cached artifacts exist.
-    recompile :: Bool,
-    -- | Recompute metadata (and recompile) even when cached.
-    rebuild :: Bool
+    wait :: Bool
   }
   deriving stock (Show)

ghc-worker/ghc-worker.cabal

@@ -86,14 +86,16 @@ executable ghc-worker
   else
       ghc-options: -O2 -threaded "-with-rtsopts=-K512M -I5 -A128M -T -N"
   build-depends:
-    ghc-worker
+    ghc-worker,
+    optparse-applicative
 
 test-suite ghc-worker-test
   import: all
   type: exitcode-stdio-1.0
   main-is: Main.hs
   hs-source-dirs: test
   other-modules:
+    BuckArgsTest,
     BuildPlanTest,
     FlagParserTest,
     IncrementalMetadataTest,

ghc-worker/lib/GhcWorker/GhcHandler.hs

@@ -28,7 +28,7 @@ import Internal.Session (withGhcMakeModule, withGhcMakeSource)
 import Prelude hiding (log)
 import Types.Args (Args (..))
 import qualified Types.BuckArgs
-import Types.BuckArgs (BuckArgs, IsInterpreted (..), Mode (..), parseBuckArgs, toGhcArgs)
+import Types.BuckArgs (BuckArgs, IsInterpreted (..), Mode (..), parseBuckArgsCli, toGhcArgs)
 import Types.Env (Env (..))
 import Types.FeatureFlags (FeatureFlags (..))
 import Types.Grpc (RequestArgs (..))
@@ -151,7 +151,7 @@ ghcHandler state featureFlags instrument traceId =
   InstrumentedHandler \ hooks -> GrpcHandler \ commandEnv argv -> do
     log <- newLogger <$> newLog traceId
     result <- try do
-      buckArgs <- either parseError pure (parseBuckArgs commandEnv argv)
+      buckArgs <- either parseError pure (parseBuckArgsCli commandEnv argv)
       args <- toGhcArgs buckArgs (Just featureFlags)
       log.debug (unlines (coerce argv))
       let env = Env {log, state, args = args}

ghc-worker/test/BuckArgsTest.hs

@@ -0,0 +1,68 @@
+module BuckArgsTest where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Map.Strict qualified as Map
+import Hedgehog (TestT, evalEither, (===))
+import Test.Run (assertJust, unitTest)
+import Test.Tasty (TestTree, testGroup)
+import Types.Args (TargetId (..))
+import Types.BuckArgs (BuckArgs (..), Mode (..), parseBuckArgsCli)
+import Types.Grpc (CommandEnv (..), RequestArgs (..))
+
+-- | Typical metadata command sent by Buck.
+metadataCommand :: [String]
+metadataCommand =
+  [
+    "-M",
+    "--ghc-dir", "buck/ghc_dir",
+    "--worker-target-id", "singleton",
+    "--build-plan", "buck/lib1.depends.json",
+    "--fields", "exposed_modules,module_graph,package_deps,th_modules,cache",
+    "--dep-units", "buck/lib1.json",
+    "--unit", "lib1",
+    "--ghc-args", "buck/lib1.args"
+  ]
+
+-- | Compile-mode command with GHC passthrough flags.
+compileCommand :: [String]
+compileCommand =
+  [
+    "-c",
+    "--unit", "lib2",
+    "--module", "Lib.Module",
+    "-O2",
+    "-package-db", "buck/db"
+  ]
+
+runParser :: [String] -> Either String BuckArgs
+runParser cmd =
+  parseBuckArgsCli (CommandEnv Map.empty) (RequestArgs cmd)
+
+test_parseMetadata :: TestT IO ()
+test_parseMetadata = do
+  BuckArgs {..}
+    <- evalEither (runParser metadataCommand)
+  assertJust ModeMetadata mode
+  assertJust "lib1" unit
+  assertJust (TargetId "singleton") workerTargetId
+  assertJust "buck/ghc_dir" ghcDirFile
+  assertJust "buck/lib1.depends.json" buildPlan
+  assertJust ("exposed_modules" :| ["module_graph", "package_deps", "th_modules", "cache"]) fields
+  assertJust "buck/lib1.json" depUnits
+  assertJust "buck/lib1.args" ghcArgsFile
+  [] === ghcOptions
+
+test_parseCompile :: TestT IO ()
+test_parseCompile = do
+  BuckArgs {mode, unit, moduleName, ghcOptions} <- evalEither (runParser compileCommand)
+  assertJust ModeCompile mode
+  assertJust "lib2" unit
+  assertJust "Lib.Module" moduleName
+  ["-O2", "-package-db", "buck/db"] === ghcOptions
+
+test_parseBuckArgs :: TestTree
+test_parseBuckArgs =
+  testGroup "parseBuckArgsCli" [
+    unitTest "metadata command" test_parseMetadata,
+    unitTest "compile command" test_parseCompile
+  ]

ghc-worker/test/Main.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE CPP #-}
 
 module Main where
- 
+
+import BuckArgsTest (test_parseBuckArgs)
 import BuildPlanTest (test_buildPlan)
 import IncrementalMetadataTest (test_incremental)
 import ProfileTest (test_profiling)
@@ -36,6 +37,7 @@ fullTest = False
 testsGeneral :: [TestTree]
 testsGeneral =
   [
+    test_parseBuckArgs,
     test_sortScheduleOrder,
     test_projectBuild,
     test_incremental

internal/src/Internal/Cache/Metadata.hs

@@ -34,7 +34,7 @@ import Internal.State (updateMakeState)
 import qualified Internal.State.Make as Make
 import Internal.State.Make (insertUnitEnv, storeModuleGraph)
 import Internal.UnitEnv (emptyHomePackageTable)
-import Types.BuckArgs (CachedBuckArgs (..), parseCachedBuckArgs)
+import Types.BuckArgs (CachedBuckArgs (..), parseCachedBuckArgsCli)
 import Types.CachedDeps (
   CachedBuildPlan (..),
   CachedBuildPlans (..),
@@ -205,7 +205,7 @@ loadCachedArgs ::
   StateT WorkerState IO ()
 loadCachedArgs path = do
   cachedArgs <- liftIO $ readFile path
-  case parseCachedBuckArgs (lines cachedArgs) of
+  case parseCachedBuckArgsCli (lines cachedArgs) of
     Right args -> modifyM (setupPath args.cachedBinPath)
     Left err -> liftIO $ throwIO (userError err)
 

ops/packages.nix

@@ -112,13 +112,15 @@
           "containers"
           "directory"
           "grapesy"
+          "optparse-applicative"
           "process"
           "text"
         ];
       };
       executables.buck-proxy = {
         dependencies = [
           "buck-worker-types"
+          "optparse-applicative"
           "unix"
         ];
         ghc-options-exe = [
@@ -222,6 +224,7 @@
           "filepath"
           "ghc"
           "ghc-paths"
+          "optparse-applicative"
           "split"
           "text"
         ];
@@ -329,9 +332,6 @@
 
       executables.gen-project = {
         source-dirs = "app/gen-project";
-        dependencies = [
-          "directory"
-        ];
       };
 
       tests.ghc-server-test = {