diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -70,6 +70,33 @@ } ``` +### Nestable data types + +You can also nest your data types, but MUST always end in a record with named fields: + +```haskell +-- Using fields, but prefixing with the Type name, because maybe the user wants to use Lenses +data GetValueParams = GetValueParams { _gvpKey :: Text } +data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text } + +data SimpleTool + = GetValue GetValueParams + | SetValue SetValueParams + deriving (Show, Eq) +``` + +Which is probably nicer for using things like Lenses etc. However we do not support positional (and unnamed) parameters such as: + +```haskell +-- Positional arguments +data SimpleTool + = GetValue Int + | SetValue Int Text + deriving (Show, Eq) +``` + +Because we don't want to be generating names when returning details in MCP definitions. + ## Custom Descriptions You can provide custom descriptions for constructors and fields using the `*WithDescription` variants: diff --git a/examples/Complete/Main.hs b/examples/Complete/Main.hs --- a/examples/Complete/Main.hs +++ b/examples/Complete/Main.hs @@ -5,7 +5,6 @@ import MCP.Server import MCP.Server.Derive -import System.IO (hPutStrLn, stderr) import Types -- High-level handler functions @@ -35,19 +34,15 @@ main :: IO () main = do - hPutStrLn stderr "Starting Template Haskell MCP Server..." - hPutStrLn stderr "Using automatic Template Haskell derivation!" - hPutStrLn stderr "Ready for JSON-RPC communication" - -- Derive the handlers using Template Haskell let prompts = $(derivePromptHandler ''MyPrompt 'handlePrompt) resources = $(deriveResourceHandler ''MyResource 'handleResource) tools = $(deriveToolHandler ''MyTool 'handleTool) in runMcpServerStdIn McpServerInfo - { serverName = "Template Haskell MCP Server" + { serverName = "Complete Example MCP Server" , serverVersion = "0.3.0" - , serverInstructions = "MCP server using Template Haskell for automatic handler derivation" + , serverInstructions = "An example MCP server that handles prompts, resources, and tools." } McpServerHandlers { prompts = Just prompts diff --git a/examples/Simple/Main.hs b/examples/Simple/Main.hs --- a/examples/Simple/Main.hs +++ b/examples/Simple/Main.hs @@ -4,7 +4,6 @@ module Main where import Data.IORef -import Data.Text (Text) import MCP.Server import MCP.Server.Derive import System.IO (hPutStrLn, stderr) @@ -29,9 +28,6 @@ writeIORef store newPairs pure $ ContentText $ "Set '" <> k <> "' to '" <> v <> "'" - hPutStrLn stderr "Using Template Haskell derivation for tools" - hPutStrLn stderr "Ready for JSON-RPC communication" - -- Derive the tool handlers using Template Haskell with descriptions let tools = $(deriveToolHandlerWithDescription ''SimpleTool 'handleTool simpleDescriptions) in runMcpServerStdIn @@ -41,7 +37,7 @@ , serverInstructions = "A simple key-value store with GetValue and SetValue tools" } McpServerHandlers - { prompts = Nothing - , resources = Nothing - , tools = Just tools + { prompts = Nothing -- No prompts in this example + , resources = Nothing -- No resources in this example + , tools = Just tools -- Only tools in this example } diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.7 +version: 0.1.0.8 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. diff --git a/src/MCP/Server/Derive.hs b/src/MCP/Server/Derive.hs --- a/src/MCP/Server/Derive.hs +++ b/src/MCP/Server/Derive.hs @@ -90,8 +90,36 @@ , promptDefinitionDescription = $(litE $ stringL description) , promptDefinitionArguments = $(return $ ListE args) } |] + NormalC name [(_bang, paramType)] -> do + -- Handle separate parameter types approach + let promptName = T.pack . toSnakeCase . nameBase $ name + let constructorName = nameBase name + let description = case lookup constructorName descriptions of + Just desc -> desc + Nothing -> "Handle " ++ constructorName + args <- extractFieldsFromType descriptions paramType + [| PromptDefinition + { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) + , promptDefinitionDescription = $(litE $ stringL description) + , promptDefinitionArguments = $(return $ ListE args) + } |] _ -> fail "Unsupported constructor type" +-- Extract field definitions from a parameter type recursively +extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp] +extractFieldsFromType descriptions paramType = do + case paramType of + ConT typeName -> do + info <- reify typeName + case info of + TyConI (DataD _ _ _ _ [RecC _ fields] _) -> do + -- Parameter type is a record with fields + sequence $ map (mkArgDef descriptions) fields + TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> do + -- Parameter type has a single parameter - recurse + extractFieldsFromType descriptions innerType + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp mkArgDef descriptions (fieldName, _, fieldType) = do @@ -120,8 +148,110 @@ let promptName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) [] +mkPromptCase handlerName (NormalC name [(_bang, paramType)]) = do + let promptName = T.pack . toSnakeCase . nameBase $ name + body <- mkSeparateParamsCase name handlerName paramType + clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) [] mkPromptCase _ _ = fail "Unsupported constructor type" +mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp +mkSeparateParamsCase conName handlerName paramType = do + fields <- extractFieldsFromParamType paramType + buildNestedFieldValidationWithConstructor conName handlerName paramType fields 0 + where + buildNestedFieldValidationWithConstructor :: Name -> Name -> Type -> [(Name, Bang, Type)] -> Int -> Q Exp + buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' [] depth = do + -- Base case: all fields validated, build parameter constructor hierarchy and outer constructor + let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]] + paramConstructorApp <- buildParameterConstructor paramType' fieldVars + let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp + [| do + content <- $(varE handlerName') $(return outerConstructorApp) + pure $ Right content |] + + buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' ((fieldName, _, fieldType):remainingFields) depth = do + let fieldStr = nameBase fieldName + let (isOptional, innerType) = case fieldType of + AppT (ConT n) inner | nameBase n == "Maybe" -> (True, inner) + other -> (False, other) + let fieldVar = mkName ("field" ++ show depth) + + continuation <- buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' remainingFields (depth + 1) + + -- Generate conversion expression based on type + let convertExpr rawVar = case innerType of + ConT n | nameBase n == "Int" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Int from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Integer" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Integer from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Double" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Double from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Float" -> + [| case readMaybe (T.unpack $(varE rawVar)) of + Just parsed -> parsed + Nothing -> error $ "Failed to parse Float from: " <> T.unpack $(varE rawVar) |] + ConT n | nameBase n == "Bool" -> + [| case T.toLower $(varE rawVar) of + "true" -> True + "false" -> False + _ -> error $ "Failed to parse Bool from: " <> T.unpack $(varE rawVar) |] + _ -> varE rawVar -- Text or other types, use as-is + + if isOptional + then do + rawFieldVar <- newName ("raw" ++ show depth) + convertedExpr <- convertExpr rawFieldVar + [| do + let $(varP fieldVar) = case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of + Nothing -> Nothing + Just $(varP rawFieldVar) -> Just $(return convertedExpr) + $(return continuation) |] + else do + rawFieldVar <- newName ("raw" ++ show depth) + convertedExpr <- convertExpr rawFieldVar + [| case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of + Just $(varP rawFieldVar) -> do + let $(varP fieldVar) = $(return convertedExpr) + $(return continuation) + Nothing -> pure $ Left $ MissingRequiredParams $ "field '" <> $(litE $ stringL fieldStr) <> "' is missing" |] + +-- Extract field information from parameter type +extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] +extractFieldsFromParamType paramType = do + case paramType of + ConT typeName -> do + info <- reify typeName + case info of + TyConI (DataD _ _ _ _ [RecC _ fields] _) -> + return fields + TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> + extractFieldsFromParamType innerType + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType + +-- Build the parameter constructor application recursively +buildParameterConstructor :: Type -> [Name] -> Q Exp +buildParameterConstructor paramType fieldVars = do + case paramType of + ConT typeName -> do + info <- reify typeName + case info of + TyConI (DataD _ _ _ _ [RecC conName _] _) -> do + -- Record constructor - apply all field variables + return $ foldl AppE (ConE conName) (map VarE fieldVars) + TyConI (DataD _ _ _ _ [NormalC conName [(_bang, innerType)]] _) -> do + -- Single parameter constructor - recurse and wrap + innerConstructor <- buildParameterConstructor innerType fieldVars + return $ AppE (ConE conName) innerConstructor + _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor" + _ -> fail $ "Parameter type must be a concrete type, got: " ++ show paramType + mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp mkRecordCase conName handlerName fields = do case fields of @@ -321,6 +451,30 @@ , required = $(return $ ListE $ map (LitE . StringL) required) } } |] + NormalC name [(_bang, paramType)] -> do + -- Handle separate parameter types approach for tools + let toolName = T.pack . toSnakeCase . nameBase $ name + let constructorName = nameBase name + let description = case lookup constructorName descriptions of + Just desc -> desc + Nothing -> constructorName + fields <- extractFieldsFromParamType paramType + props <- sequence $ map (mkProperty descriptions) fields + requiredFields <- return $ map (\(fieldName, _, fieldType) -> + let isOptional = case fieldType of + AppT (ConT n) _ -> nameBase n == "Maybe" + _ -> False + in if isOptional then Nothing else Just (nameBase fieldName) + ) fields + let required = [f | Just f <- requiredFields] + [| ToolDefinition + { toolDefinitionName = $(litE $ stringL $ T.unpack toolName) + , toolDefinitionDescription = $(litE $ stringL description) + , toolDefinitionInputSchema = InputSchemaDefinitionObject + { properties = $(return $ ListE props) + , required = $(return $ ListE $ map (LitE . StringL) required) + } + } |] _ -> fail "Unsupported constructor type for tools" @@ -361,5 +515,9 @@ mkToolCase handlerName (RecC name fields) = do let toolName = T.pack . toSnakeCase . nameBase $ name body <- mkRecordCase name handlerName fields + clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) [] +mkToolCase handlerName (NormalC name [(_bang, paramType)]) = do + let toolName = T.pack . toSnakeCase . nameBase $ name + body <- mkSeparateParamsCase name handlerName paramType clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) [] mkToolCase _ _ = fail "Unsupported constructor type for tools" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -146,6 +146,22 @@ testToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) testToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''TestTool 'handleTestTool testDescriptions) +-- Test case for separate parameter types approach (should fail with current implementation) +testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool) + +-- Test case for recursive parameter types +testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool) + +-- Test case for separate parameter types with descriptions +testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions) + +-- Test case for recursive parameter types with descriptions +testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO) +testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions) + -- End-to-end test functions testPromptDerivation :: IO Bool testPromptDerivation = do @@ -177,6 +193,120 @@ return (test1 && test2 && test3 && test4) +testSeparateParamsDerivation :: IO Bool +testSeparateParamsDerivation = do + putStrLn "Testing separate parameter types derivation..." + + -- Test the separate parameter types approach + let (listHandler, callHandler) = testSeparateParamsToolHandlers + + -- First test that tool definitions are generated correctly + toolDefs <- listHandler + let getValueDef = filter (\def -> toolDefinitionName def == "get_value") toolDefs + let setValueDef = filter (\def -> toolDefinitionName def == "set_value") toolDefs + + let schemaTest = case (getValueDef, setValueDef) of + ([getDef], [setDef]) -> + let getProps = case toolDefinitionInputSchema getDef of + InputSchemaDefinitionObject props _ -> map fst props + setProps = case toolDefinitionInputSchema setDef of + InputSchemaDefinitionObject props _ -> map fst props + in "_gvpKey" `elem` getProps && "_svpKey" `elem` setProps && "_svpValue" `elem` setProps + _ -> False + + putStrLn $ " Schema generation: " ++ (if schemaTest then "PASS" else "FAIL") + + -- Test GetValue with separate params + result1 <- callHandler "get_value" [("_gvpKey", "mykey")] + let test1 = case result1 of + Right (ContentText content) -> content == "Getting value for key: mykey" + _ -> False + + putStrLn $ " GetValue execution: " ++ (if test1 then "PASS" else "FAIL") + + -- Test SetValue with separate params + result2 <- callHandler "set_value" [("_svpKey", "mykey"), ("_svpValue", "myvalue")] + let test2 = case result2 of + Right (ContentText content) -> content == "Setting mykey = myvalue" + _ -> False + + putStrLn $ " SetValue execution: " ++ (if test2 then "PASS" else "FAIL") + + -- Test recursive parameter types + let (recursiveListHandler, recursiveCallHandler) = testRecursiveToolHandlers + recursiveToolDefs <- recursiveListHandler + let processDataDef = filter (\def -> toolDefinitionName def == "process_data") recursiveToolDefs + + let recursiveSchemaTest = case processDataDef of + [def] -> case toolDefinitionInputSchema def of + InputSchemaDefinitionObject props _ -> + let propNames = map fst props + in "_ipName" `elem` propNames && "_ipAge" `elem` propNames + _ -> False + + putStrLn $ " Recursive schema generation: " ++ (if recursiveSchemaTest then "PASS" else "FAIL") + + -- Test recursive execution + result3 <- recursiveCallHandler "process_data" [("_ipName", "Alice"), ("_ipAge", "30")] + let test3 = case result3 of + Right (ContentText content) -> content == "Processing data for Alice (age 30)" + _ -> False + + putStrLn $ " Recursive execution: " ++ (if test3 then "PASS" else "FAIL") + + -- Test descriptions with separate parameter types + let (descListHandler, _) = testSeparateParamsToolHandlersWithDescriptions + descToolDefs <- descListHandler + let getValueDefWithDesc = filter (\def -> toolDefinitionName def == "get_value") descToolDefs + let setValueDefWithDesc = filter (\def -> toolDefinitionName def == "set_value") descToolDefs + + let descriptionTest = case (getValueDefWithDesc, setValueDefWithDesc) of + ([getDef], [setDef]) -> + let getDefDescCorrect = toolDefinitionDescription getDef == "Retrieves a value from the key-value store" + setDefDescCorrect = toolDefinitionDescription setDef == "Sets a value in the key-value store" + getFieldDescsCorrect = case toolDefinitionInputSchema getDef of + InputSchemaDefinitionObject props _ -> + case lookup "_gvpKey" props of + Just prop -> propertyDescription prop == "The key to retrieve the value for" + Nothing -> False + setFieldDescsCorrect = case toolDefinitionInputSchema setDef of + InputSchemaDefinitionObject props _ -> + let keyDesc = case lookup "_svpKey" props of + Just prop -> propertyDescription prop == "The key to set the value for" + Nothing -> False + valueDesc = case lookup "_svpValue" props of + Just prop -> propertyDescription prop == "The value to store" + Nothing -> False + in keyDesc && valueDesc + in getDefDescCorrect && setDefDescCorrect && getFieldDescsCorrect && setFieldDescsCorrect + _ -> False + + putStrLn $ " Description support: " ++ (if descriptionTest then "PASS" else "FAIL") + + -- Test recursive descriptions + let (recursiveDescListHandler, _) = testRecursiveToolHandlersWithDescriptions + recursiveDescToolDefs <- recursiveDescListHandler + let processDataDefWithDesc = filter (\def -> toolDefinitionName def == "process_data") recursiveDescToolDefs + + let recursiveDescTest = case processDataDefWithDesc of + [procDef] -> + let procDefDescCorrect = toolDefinitionDescription procDef == "Processes user data with age validation" + procFieldDescsCorrect = case toolDefinitionInputSchema procDef of + InputSchemaDefinitionObject props _ -> + let nameDesc = case lookup "_ipName" props of + Just prop -> propertyDescription prop == "The person's full name" + Nothing -> False + ageDesc = case lookup "_ipAge" props of + Just prop -> propertyDescription prop == "The person's age in years" + Nothing -> False + in nameDesc && ageDesc + in procDefDescCorrect && procFieldDescsCorrect + _ -> False + + putStrLn $ " Recursive description support: " ++ (if recursiveDescTest then "PASS" else "FAIL") + + return (schemaTest && test1 && test2 && recursiveSchemaTest && test3 && descriptionTest && recursiveDescTest) + testResourceDerivation :: IO Bool testResourceDerivation = do let (_, readHandler) = testResourceHandlers @@ -315,7 +445,11 @@ descriptionResult <- testCustomDescriptions putStrLn $ if descriptionResult then "PASS" else "FAIL" - let allPassed = promptResult && resourceResult && toolResult && schemaResult && descriptionResult + putStr "Testing separate parameter types: " + separateParamsResult <- testSeparateParamsDerivation + putStrLn $ if separateParamsResult then "PASS" else "FAIL" + + let allPassed = promptResult && resourceResult && toolResult && schemaResult && descriptionResult && separateParamsResult putStrLn $ "End-to-End result: " ++ if allPassed then "PASS" else "FAIL" return allPassed diff --git a/test/TestTypes.hs b/test/TestTypes.hs --- a/test/TestTypes.hs +++ b/test/TestTypes.hs @@ -26,6 +26,25 @@ | Search { query :: Text, limit :: Maybe Int, caseSensitive :: Maybe Bool } deriving (Show, Eq) +-- Test separate parameter types approach (should fail with current implementation) +data GetValueParams = GetValueParams { _gvpKey :: Text } + deriving (Show, Eq) +data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text } + deriving (Show, Eq) + +data SeparateParamsTool + = GetValue GetValueParams + | SetValue SetValueParams + deriving (Show, Eq) + +-- Test recursive parameter types +data InnerParams = InnerParams { _ipName :: Text, _ipAge :: Int } + deriving (Show, Eq) +data MiddleParams = MiddleParams InnerParams + deriving (Show, Eq) +data RecursiveTool = ProcessData MiddleParams + deriving (Show, Eq) + -- Handler functions handleTestPrompt :: TestPrompt -> IO Content handleTestPrompt (SimplePrompt msg) = @@ -60,6 +79,18 @@ maybe "" ((" (limit=" <>) . (<> ")") . T.pack . show) limit <> maybe "" ((" (case-sensitive=" <>) . (<> ")") . T.pack . show) caseSens +-- Handler for separate params tool +handleSeparateParamsTool :: SeparateParamsTool -> IO Content +handleSeparateParamsTool (GetValue (GetValueParams key)) = + pure $ ContentText $ "Getting value for key: " <> key +handleSeparateParamsTool (SetValue (SetValueParams key value)) = + pure $ ContentText $ "Setting " <> key <> " = " <> value + +-- Handler for recursive tool +handleRecursiveTool :: RecursiveTool -> IO Content +handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) = + pure $ ContentText $ "Processing data for " <> name <> " (age " <> T.pack (show age) <> ")" + -- Test descriptions for custom description functionality testDescriptions :: [(String, String)] testDescriptions = @@ -69,4 +100,17 @@ , ("operation", "The mathematical operation to perform") , ("x", "The first number") , ("y", "The second number") + ] + +-- Test descriptions for separate parameter types +separateParamsDescriptions :: [(String, String)] +separateParamsDescriptions = + [ ("GetValue", "Retrieves a value from the key-value store") + , ("SetValue", "Sets a value in the key-value store") + , ("_gvpKey", "The key to retrieve the value for") + , ("_svpKey", "The key to set the value for") + , ("_svpValue", "The value to store") + , ("ProcessData", "Processes user data with age validation") + , ("_ipName", "The person's full name") + , ("_ipAge", "The person's age in years") ]