diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,16 @@ ## [Unreleased] +## [0.2.0.0] - 2026-10-23 + +### Changed + +- The `status` tool now shows only the first line of a test suite's error + message unless `verbose` is set. + ([#585](https://github.com/tweag/tricorder/issues/585)) +- The `test_results` tool now uses the new, more granular + `tricorder test suites` command. + ## [0.1.3.1] - 2026-10-20 ### Fixed diff --git a/src/Tricorder/MCP/Derive.hs b/src/Tricorder/MCP/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Tricorder/MCP/Derive.hs @@ -0,0 +1,80 @@ +-- | A checked wrapper around 'deriveToolHandlerWithOptions'. +-- +-- @mcp-server@ looks up tool and field descriptions by name, so a missing, +-- misspelt or stale entry silently falls back to the bare constructor or field +-- name. 'deriveCheckedToolHandler' reifies the tool type and fails compilation +-- unless the descriptions cover exactly its constructors, and each +-- constructor's descriptions cover exactly its fields. +module Tricorder.MCP.Derive (deriveCheckedToolHandler) where + +import Language.Haskell.TH (Con (..), Dec (..), Exp, Info (..), Name, Q, Type (..), nameBase, reify) +import MCP.Server.Derive (DefinitionOptions (..), deriveToolHandlerWithOptions) + +import Data.List qualified as List + + +deriveCheckedToolHandler :: Name -> Name -> [(String, DefinitionOptions)] -> Q Exp +deriveCheckedToolHandler typeName handlerName opts = do + cons <- reifyCons typeName + conProblems <- concat <$> traverse checkCon cons + let conNames = map (nameBase . conName) cons + problems = + conProblems + <> mismatches "tool" (nameBase typeName) conNames (map fst opts) + unless (null problems) + $ fail + $ List.unlines + $ ("Tool descriptions are out of sync with " <> nameBase typeName <> ":") + : map (" - " <>) problems + deriveToolHandlerWithOptions typeName handlerName opts + where + checkCon con = do + let name = nameBase (conName con) + fields <- conFieldNames con + pure $ case List.lookup name opts of + Nothing -> [] + Just o -> + mismatches "field" name fields (map (toString . fst) (optFieldDescriptions o)) + + +-- | Report entries missing from, or unknown to, the expected set of names. +mismatches :: String -> String -> [String] -> [String] -> [String] +mismatches kind owner expected described = + [ "missing " <> kind <> " description for " <> owner <> "." <> n + | n <- expected List.\\ described + ] + <> [ "description for unknown " <> kind <> " " <> owner <> "." <> n + | n <- described List.\\ expected + ] + + +reifyCons :: Name -> Q [Con] +reifyCons n = + reify n >>= \case + TyConI (DataD _ _ _ _ cs _) -> pure cs + TyConI (NewtypeD _ _ _ _ c _) -> pure [c] + _ -> fail $ nameBase n <> " is not a data type or newtype" + + +conName :: Con -> Name +conName = \case + NormalC n _ -> n + RecC n _ -> n + InfixC _ n _ -> n + ForallC _ _ c -> conName c + GadtC (n : _) _ _ -> n + RecGadtC (n : _) _ _ -> n + _ -> error "conName: unsupported constructor" + + +-- | The argument fields of a tool constructor, following the same shapes +-- @mcp-server@ accepts: nullary, a record, or a single record-typed argument. +conFieldNames :: Con -> Q [String] +conFieldNames = \case + NormalC _ [] -> pure [] + RecC _ fields -> pure [nameBase f | (f, _, _) <- fields] + NormalC _ [(_, ConT param)] -> + reifyCons param >>= \case + [RecC _ fields] -> pure [nameBase f | (f, _, _) <- fields] + _ -> fail $ nameBase param <> " must be a single-constructor record" + con -> fail $ "Unsupported tool constructor: " <> nameBase (conName con) diff --git a/src/Tricorder/MCP/Main.hs b/src/Tricorder/MCP/Main.hs --- a/src/Tricorder/MCP/Main.hs +++ b/src/Tricorder/MCP/Main.hs @@ -7,9 +7,9 @@ , noHandlers , runMcpServerStdio ) -import MCP.Server.Derive (deriveToolHandlerWithOptions) import Paths_tricorder_mcp (version) +import Tricorder.MCP.Derive (deriveCheckedToolHandler) import Tricorder.MCP.Tools (Tool, handleTool, toolDescriptions) @@ -20,7 +20,7 @@ handlers :: McpServerHandlers handlers = noHandlers - { tools = Just $(deriveToolHandlerWithOptions ''Tool 'handleTool toolDescriptions) + { tools = Just $(deriveCheckedToolHandler ''Tool 'handleTool toolDescriptions) } diff --git a/src/Tricorder/MCP/Tools.hs b/src/Tricorder/MCP/Tools.hs --- a/src/Tricorder/MCP/Tools.hs +++ b/src/Tricorder/MCP/Tools.hs @@ -4,7 +4,7 @@ , StopOptions (..) , RestartOptions (..) , StatusOptions (..) - , TestResultsOptions (..) + , TestSuitesOptions (..) , SourceOptions (..) , EvalCommentsOptions (..) , LogPathOptions (..) @@ -24,23 +24,36 @@ import System.Exit (ExitCode (..)) import System.Posix (getWorkingDirectory) import System.Process.Typed (proc, readProcess, setWorkingDir) -import Tricorder.CLI.Command.OutputFormat (OutputFormat (..)) -import Tricorder.CLI.Command.WaitMode (WaitMode) +import Tricorder.API.Force (Force) +import Tricorder.API.OutputFormat (OutputFormat (..)) +import Tricorder.API.TestFilter (TestFilter) +import Tricorder.API.WaitMode (WaitMode) import Tricorder.SourceLookup.SourceQuery (parseSourceQuery) import Prelude hiding (force) import Data.ByteString.Lazy qualified as BSL import Data.List qualified as List -import Tricorder.CLI.Command qualified as CLI -import Tricorder.CLI.Command.WaitMode qualified as WaitMode +import Options.Applicative.Help qualified as Doc +import Tricorder.API.Command qualified as Command +import Tricorder.API.Daemon.Command qualified as Daemon.Command +import Tricorder.API.FieldMask qualified as FieldMask +import Tricorder.API.FieldMask.Args qualified as FieldMask.Args +import Tricorder.API.FieldMask.Schema qualified as FieldMask.Schema +import Tricorder.API.Force qualified as Force +import Tricorder.API.IfDaemonIsStopped qualified as IfDaemonIsStopped +import Tricorder.API.OutputFormat qualified as OutputFormat +import Tricorder.API.Test qualified as Test +import Tricorder.API.Test.SuiteView.Schema qualified as Test.SuiteView.Schema +import Tricorder.API.TestFilter qualified as TestFilter +import Tricorder.API.WaitMode qualified as WaitMode data Tool - = Start StartOptions - | Stop StopOptions - | Restart RestartOptions + = StartDaemon StartOptions + | StopDaemon StopOptions + | RestartDaemon RestartOptions | Status StatusOptions - | TestResults TestResultsOptions + | TestSuites TestSuitesOptions | Source SourceOptions | EvalComments EvalCommentsOptions | LogPath LogPathOptions @@ -70,10 +83,12 @@ } -data TestResultsOptions = TestResultsOptions - { failed :: Maybe Bool +data TestSuitesOptions = TestSuitesOptions + { testFilter :: Maybe TestFilter , wait :: Maybe Bool , projectRoot :: Maybe Text + , fields :: Maybe Text + , suiteNames :: Maybe [Text] } @@ -102,7 +117,7 @@ toolDescriptions :: [(String, DefinitionOptions)] toolDescriptions = [ - ( "Start" + ( "StartDaemon" , defaultDefinitionOptions { optDescription = Just "Start the tricorder daemon (no-op if already running)." , optTitle = Just "Start daemon" @@ -110,23 +125,23 @@ } ) , - ( "Stop" + ( "StopDaemon" , defaultDefinitionOptions { optDescription = Just "Stop the tricorder daemon." , optTitle = Just "Stop daemon" , optFieldDescriptions = - [ ("force", "Ignore pending queries instead of waiting for them to finish.") + [ forceDesc , projectRootDesc ] } ) , - ( "Restart" + ( "RestartDaemon" , defaultDefinitionOptions { optDescription = Just "Restart the tricorder daemon." , optTitle = Just "Restart daemon" , optFieldDescriptions = - [ ("force", "Ignore pending queries instead of waiting for them to finish.") + [ forceDesc , projectRootDesc ] } @@ -137,21 +152,43 @@ { optDescription = Just "Get the current GHCi build status: diagnostics, errors and warnings." , optTitle = Just "View built status" , optFieldDescriptions = - [ ("wait", "Block until the current build cycle finishes before returning.") - , ("verbose", "Include the full GHC message body under each diagnostic.") + [ waitDesc + , ("verbose", "Include full GHC message bodies and full test suite error messages.") , ("expand", "Only show the summary line and full message body for diagnostic #N.") , projectRootDesc ] } ) , - ( "TestResults" + ( "TestSuites" , defaultDefinitionOptions { optDescription = Just "Show output from the latest test suite runs." , optTitle = Just "View test results" , optFieldDescriptions = - [ ("wait", "Block until the current build cycle finishes before returning.") - , ("failed", "Only show output from failed test suites.") + [ waitDesc + , + ( "testFilter" + , "Whether to show all test results, or only the test results that failed. Valid options are 'All' and 'FailedOnly'. Defaults to 'All' if not set." + ) + , + ( "fields" + , show + $ mconcat + $ Doc.punctuate + Doc.hardline + [ "Comma-separated list of fields to include in the result." + , "Available fields:" + , Doc.indent 4 (Doc.vsep $ FieldMask.Schema.render Test.SuiteView.Schema.schema) + , "Select nested fields with parentheses," + , "e.g. --fields 'name,cases(description,failure)'." + , "Default fields, when unspecified, are as follows:" + , Doc.pretty $ FieldMask.render Test.SuiteView.Schema.defaultFields + ] + ) + , + ( "suiteNames" + , "Test suites to focus on. In the form '::'. E.g. 'tricorder:test:tricorder-test'" + ) , projectRootDesc ] } @@ -175,7 +212,7 @@ { optDescription = Just "Show eval comments and their evaluated results from the latest build." , optTitle = Just "View eval comments" , optFieldDescriptions = - [ ("wait", "Block until the current build cycle finishes before returning.") + [ waitDesc , projectRootDesc ] } @@ -204,67 +241,105 @@ \commands. Usually where the `cabal.project`, `.cabal` file or\ \`package.yaml` lives. Defaults to the current working directory." ) + waitDesc = + ( "wait" + , "Block and wait until the current build cycle finishes to provide the most up-to-date result." + ) + forceDesc = ("force", "Ignore pending queries instead of waiting for them to finish.") -- | The @tricorder@ invocation for a tool call: the project directory to run -- it in, and the subcommand plus flags to pass. Builds the shared 'CLI.Command' -- and renders it via 'CLI.commandToArgs' so the flags stay in sync with -- "Tricorder.CLI.Arguments" instead of being duplicated here. -toolCommand :: Tool -> (Maybe Text, [String]) +toolCommand :: Tool -> (Maybe Text, Either Text [String]) toolCommand = \case - Start (StartOptions {projectRoot}) -> - (projectRoot, CLI.commandToArgs CLI.Start) - (Stop (StopOptions {force, projectRoot})) -> - (projectRoot, CLI.commandToArgs $ CLI.Stop $ toForce force) - (Restart (RestartOptions {force, projectRoot})) -> - (projectRoot, CLI.commandToArgs $ CLI.Restart $ toForce force) - (Status (StatusOptions {wait, verbose, expand, projectRoot})) -> + StartDaemon (StartOptions {projectRoot}) -> ( projectRoot - , CLI.commandToArgs - $ CLI.Status - CLI.StatusOptions + , Right $ Daemon.Command.toArgs Daemon.Command.Start + ) + StopDaemon (StopOptions {force, projectRoot}) -> + ( projectRoot + , Right + $ Daemon.Command.toArgs + $ Daemon.Command.Stop + $ toForce force + ) + RestartDaemon (RestartOptions {force, projectRoot}) -> + ( projectRoot + , Right + $ Daemon.Command.toArgs + $ Daemon.Command.Restart + $ toForce force + ) + Status (StatusOptions {wait, verbose, expand, projectRoot}) -> + ( projectRoot + , Right + $ Command.toArgs + $ Command.Status + Command.StatusOptions { wait = toWaitMode wait , format = JsonOutput , verbosity = toVerbosity verbose , expand + , ifDaemonIsStopped = IfDaemonIsStopped.StartDaemon } ) - (TestResults (TestResultsOptions {failed, wait, projectRoot})) -> - ( projectRoot - , CLI.commandToArgs - $ CLI.TestResults - CLI.TestOptions - { failedOnly = fromMaybe False failed - , wait = toWaitMode wait + TestSuites opts -> + ( opts.projectRoot + , do + fields <- traverse FieldMask.Args.parse opts.fields + Right + $ Command.toArgs + $ Command.Test + $ Test.Suites + $ Test.SuitesOptions + { testFilter = fromMaybe TestFilter.All opts.testFilter + , wait = toWaitMode opts.wait + , suiteNames = fromMaybe [] opts.suiteNames + , format = OutputFormat.JsonOutput + , ifDaemonIsStopped = IfDaemonIsStopped.StartDaemon + , fields } ) - (Source (SourceOptions {modules, projectRoot})) -> + Source (SourceOptions {modules, projectRoot}) -> ( projectRoot - , CLI.commandToArgs - $ CLI.Source - CLI.SourceOptions + , Right + $ Command.toArgs + $ Command.Source + Command.SourceOptions { queries = parseSourceQuery <$> modules , maxDepth = Nothing , maxModules = Nothing } ) - (EvalComments (EvalCommentsOptions {wait, projectRoot})) -> + EvalComments (EvalCommentsOptions {wait, projectRoot}) -> ( projectRoot - , CLI.commandToArgs - $ CLI.EvalComments - CLI.EvalCommentsOptions + , Right + $ Command.toArgs + $ Command.EvalComments + Command.EvalCommentsOptions { wait = toWaitMode wait , format = JsonOutput + , ifDaemonIsStopped = IfDaemonIsStopped.StartDaemon } ) LogPath (LogPathOptions {projectRoot}) -> - (projectRoot, CLI.commandToArgs $ CLI.Log CLI.ShowLogPath) + ( projectRoot + , Right + $ Command.toArgs + $ Command.Log Command.ShowLogPath + ) LogContents (LogContentsOptions {projectRoot}) -> - (projectRoot, CLI.commandToArgs $ CLI.Log CLI.ShowLog) + ( projectRoot + , Right + $ Command.toArgs + $ Command.Log Command.ShowLog + ) -toForce :: Maybe Bool -> CLI.Force -toForce = maybe CLI.NoForce (\enabled -> if enabled then CLI.Force else CLI.NoForce) +toForce :: Maybe Bool -> Force +toForce = maybe Force.NoForce (\enabled -> if enabled then Force.Force else Force.NoForce) toWaitMode :: Maybe Bool -> WaitMode @@ -274,8 +349,8 @@ (\enabled -> if enabled then WaitMode.WaitForBuild else WaitMode.ShowCurrent) -toVerbosity :: Maybe Bool -> CLI.Verbosity -toVerbosity = maybe CLI.Concise (\enabled -> if enabled then CLI.Verbose else CLI.Concise) +toVerbosity :: Maybe Bool -> Command.Verbosity +toVerbosity = maybe Command.Concise (\enabled -> if enabled then Command.Verbose else Command.Concise) -- | Whether a tool's exit code reports a build/test outcome (errors present, @@ -286,7 +361,7 @@ -- genuine execution failure. reportsBuildOutcome :: Tool -> Bool reportsBuildOutcome (Status _) = True -reportsBuildOutcome (TestResults _) = True +reportsBuildOutcome (TestSuites _) = True reportsBuildOutcome (EvalComments _) = True reportsBuildOutcome _ = False @@ -297,27 +372,29 @@ -- uncaught it would take the whole server down with it, not just this -- request. handleTool :: ClientContext -> Tool -> IO ToolResult -handleTool _ tool = do - mDir <- case passedDir of - Just dir -> pure $ Right $ toString dir - Nothing -> getProjectRoot - case mDir of - Left err -> - pure $ toolError $ "Failed to run tricorder: " <> err - Right directory -> do - outcome <- - try @IOException - $ readProcess - $ setWorkingDir directory - $ proc "tricorder" args - pure $ case outcome of - Left ex -> toolError $ "Failed to run tricorder: " <> show ex - Right (ExitSuccess, out, _) -> toolResult [ContentText (decodeUtf8 out)] - Right (ExitFailure _, out, _) | reportsBuildOutcome tool -> toolResult [ContentText (decodeUtf8 out)] - Right (ExitFailure _, out, err) -> - toolError $ "tricorder failed: " <> decodeUtf8 (if BSL.null err then out else err) +handleTool _ tool = case argsRes of + Left err -> pure $ toolError $ "Tool failed with given input: " <> err + Right args -> do + mDir <- case passedDir of + Just dir -> pure $ Right $ toString dir + Nothing -> getProjectRoot + case mDir of + Left err -> + pure $ toolError $ "Failed to run tricorder: " <> err + Right directory -> do + outcome <- + try @IOException + $ readProcess + $ setWorkingDir directory + $ proc "tricorder" args + pure $ case outcome of + Left ex -> toolError $ "Failed to run tricorder: " <> show ex + Right (ExitSuccess, out, _) -> toolResult [ContentText (decodeUtf8 out)] + Right (ExitFailure _, out, _) | reportsBuildOutcome tool -> toolResult [ContentText (decodeUtf8 out)] + Right (ExitFailure _, out, err) -> + toolError $ "tricorder failed: " <> decodeUtf8 (if BSL.null err then out else err) where - (passedDir, args) = toolCommand tool + (passedDir, argsRes) = toolCommand tool getProjectRoot :: IO (Either Text FilePath) diff --git a/test/Unit/Tricorder/MCP/ToolsSpec.hs b/test/Unit/Tricorder/MCP/ToolsSpec.hs --- a/test/Unit/Tricorder/MCP/ToolsSpec.hs +++ b/test/Unit/Tricorder/MCP/ToolsSpec.hs @@ -12,7 +12,7 @@ , StartOptions (..) , StatusOptions (..) , StopOptions (..) - , TestResultsOptions (..) + , TestSuitesOptions (..) , Tool (..) , reportsBuildOutcome , toolCommand @@ -26,24 +26,24 @@ [ testGroup "toolCommand" [ testCase "starts with just the directory" - $ toolCommand (Start StartOptions {projectRoot = Nothing}) - @?= (Nothing, ["start"]) + $ toolCommand (StartDaemon StartOptions {projectRoot = Nothing}) + @?= (Nothing, Right ["start"]) , testCase "omits --force when unset" - $ toolCommand (Stop (StopOptions {force = Nothing, projectRoot = Nothing})) - @?= (Nothing, ["stop"]) + $ toolCommand (StopDaemon (StopOptions {force = Nothing, projectRoot = Nothing})) + @?= (Nothing, Right ["stop"]) , testCase "omits --force when explicitly false" - $ toolCommand (Restart (RestartOptions {force = Just False, projectRoot = Nothing})) - @?= (Nothing, ["restart"]) + $ toolCommand (RestartDaemon (RestartOptions {force = Just False, projectRoot = Nothing})) + @?= (Nothing, Right ["restart"]) , testCase "includes --force when true" $ toolCommand - ( Stop + ( StopDaemon ( StopOptions { force = Just True , projectRoot = Nothing } ) ) - @?= (Nothing, ["stop", "--force"]) + @?= (Nothing, Right ["stop", "--force"]) , testCase "combines status flags in order, with --expand carrying its argument" $ toolCommand ( Status @@ -54,7 +54,7 @@ , projectRoot = Nothing } ) - @?= (Nothing, ["status", "--wait", "--json", "--expand", "3"]) + @?= (Nothing, Right ["status", "--wait", "--json", "--expand", "3"]) , testCase "turns modules into positional arguments" $ toolCommand ( Source @@ -64,24 +64,25 @@ } ) ) - @?= (Nothing, ["source", "Data.Map.Strict", "Foo#bar"]) + @?= (Nothing, Right ["source", "Data.Map.Strict", "Foo#bar"]) , testCase "maps log_path to --print-path" $ toolCommand (LogPath LogPathOptions {projectRoot = Nothing}) - @?= (Nothing, ["log", "--print-path"]) + @?= (Nothing, Right ["log", "--print-path"]) , testCase "maps log_contents to plain log" $ toolCommand (LogContents LogContentsOptions {projectRoot = Nothing}) - @?= (Nothing, ["log"]) + @?= (Nothing, Right ["log"]) ] , testGroup "reportsBuildOutcome" [ testCase "is true for status, test_results and eval_comments" do reportsBuildOutcome (Status (StatusOptions Nothing Nothing Nothing Nothing)) @?= True - reportsBuildOutcome (TestResults (TestResultsOptions Nothing Nothing Nothing)) @?= True + reportsBuildOutcome (TestSuites (TestSuitesOptions Nothing Nothing Nothing Nothing Nothing)) + @?= True reportsBuildOutcome (EvalComments (EvalCommentsOptions Nothing Nothing)) @?= True , testCase "is false for commands whose exit code reflects process failure" do - reportsBuildOutcome (Start $ StartOptions Nothing) @?= False - reportsBuildOutcome (Stop $ StopOptions Nothing Nothing) @?= False - reportsBuildOutcome (Restart $ RestartOptions Nothing Nothing) @?= False + reportsBuildOutcome (StartDaemon $ StartOptions Nothing) @?= False + reportsBuildOutcome (StopDaemon $ StopOptions Nothing Nothing) @?= False + reportsBuildOutcome (RestartDaemon $ RestartOptions Nothing Nothing) @?= False reportsBuildOutcome (Source $ SourceOptions [] Nothing) @?= False reportsBuildOutcome (LogPath $ LogPathOptions Nothing) @?= False reportsBuildOutcome (LogContents $ LogContentsOptions Nothing) @?= False diff --git a/tricorder-mcp.cabal b/tricorder-mcp.cabal --- a/tricorder-mcp.cabal +++ b/tricorder-mcp.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tricorder-mcp -version: 0.1.3.1 +version: 0.2.0.0 synopsis: MCP server for Tricorder description: Model Context Protocol server for Tricorder. category: AI, @@ -33,6 +33,7 @@ library tricorder-mcp-internal exposed-modules: + Tricorder.MCP.Derive Tricorder.MCP.Main Tricorder.MCP.Tools other-modules: @@ -68,8 +69,10 @@ , effectful-core ==2.7.* , effectful-plugin ==2.2.* , mcp-server ==0.2.* + , optparse-applicative ==0.19.* , process ==1.6.* - , tricorder-types ==0.5.* + , template-haskell >=2.20 && <2.25 + , tricorder-types ==0.6.* , typed-process ==0.2.* , unix ==2.8.* mixins: