tricorder-mcp 0.1.3.1 → 0.2.0.0
raw patch · 6 files changed
+267/−96 lines, 6 filesdep +optparse-applicativedep +template-haskelldep ~tricorder-types
Dependencies added: optparse-applicative, template-haskell
Dependency ranges changed: tricorder-types
Files
- CHANGELOG.md +10/−0
- src/Tricorder/MCP/Derive.hs +80/−0
- src/Tricorder/MCP/Main.hs +2/−2
- src/Tricorder/MCP/Tools.hs +152/−75
- test/Unit/Tricorder/MCP/ToolsSpec.hs +18/−17
- tricorder-mcp.cabal +5/−2
CHANGELOG.md view
@@ -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
+ src/Tricorder/MCP/Derive.hs view
@@ -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)
src/Tricorder/MCP/Main.hs view
@@ -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) }
src/Tricorder/MCP/Tools.hs view
@@ -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 '<package>:<kind>:<component-name>'. 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)
test/Unit/Tricorder/MCP/ToolsSpec.hs view
@@ -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
tricorder-mcp.cabal view
@@ -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: