mcp-server 0.1.0.18 → 0.1.0.19
raw patch · 7 files changed
+493/−346 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−1
- mcp-server.cabal +10/−6
- src/MCP/Server/Derive.hs +243/−339
- src/MCP/Server/Derive/Internal.hs +43/−0
- test/HspecMain.hs +2/−0
- test/Spec/ToolCallParsing.hs +148/−0
- test/TestTypes.hs +40/−0
CHANGELOG.md view
@@ -1,6 +1,12 @@ # Revision history for mcp-server -## Unreleased+## 0.1.0.19 - ???++* Improve handler code generated by TemplateHaskell functions in `MCP.Server.Derive`:+ * Don't repeat `Map.fromList` for each argument in map lookup+ * Properly handle argument parse errors (Return `InvalidParams` error instead of crashing mcp server with `error`)++## 0.1.0.18 - 2026-02-09 * Switch default-language to GHC2021 to support broader range of GHC versions (9.6 - 9.12)
mcp-server.cabal view
@@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.1.0.18+version: 0.1.0.19 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package.@@ -45,8 +45,10 @@ extra-doc-files: CHANGELOG.md README.md--tested-with: ghc ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2+tested-with: GHC == 9.6.7+ || == 9.8.4+ || == 9.10.3+ || == 9.12.2 -- Extra source files to be distributed with the package, such as examples, or a tutorial module. -- extra-source-files: SPEC.md@@ -56,9 +58,7 @@ location: https://github.com/drshade/haskell-mcp-server.git common warnings- ghc-options:- -Wall- -Wunused-packages+ ghc-options: -Wall -Wunused-packages library -- Import common warning flags.@@ -74,6 +74,9 @@ MCP.Server.Transport.Stdio MCP.Server.Types + other-modules:+ MCP.Server.Derive.Internal+ -- Modules included in this library but not exported. -- other-modules: -- LANGUAGE extensions used by modules in this package.@@ -168,6 +171,7 @@ Spec.JSONConversion Spec.ProtocolVersionNegotiation Spec.SchemaValidation+ Spec.ToolCallParsing Spec.UnicodeHandling TestData TestTypes
src/MCP/Server/Derive.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +-- | Template Haskell utilities for deriving MCP handlers from data types. module MCP.Server.Derive ( -- * Template Haskell Derivation derivePromptHandler@@ -12,14 +13,22 @@ ) where import qualified Data.Map as Map+import Data.Maybe (fromMaybe) import qualified Data.Text as T import Language.Haskell.TH-import Text.Read (readMaybe) import qualified Data.Char as Char +import MCP.Server.Derive.Internal import MCP.Server.Types +-------------------------------------------------------------------------------+-- Small helpers+-------------------------------------------------------------------------------+ -- Helper function to convert PascalCase/camelCase to snake_case+--+-- >>> toSnakeCase "GetValue"+-- "get_value" toSnakeCase :: String -> String toSnakeCase [] = [] toSnakeCase (x:xs) = Char.toLower x : go xs@@ -29,84 +38,111 @@ | Char.isUpper c = '_' : Char.toLower c : go cs | otherwise = c : go cs +-- Snake-cased name from a TH Name+snakeName :: Name -> String+snakeName = toSnakeCase . nameBase++-- Check if a type is Maybe, and unwrap it+unwrapMaybe :: Type -> (Bool, Type)+unwrapMaybe (AppT (ConT n) inner) | nameBase n == "Maybe" = (True, inner)+unwrapMaybe other = (False, other)++-- Look up description with a default+descriptionFor :: [(String, String)] -> String -> String -> String+descriptionFor descriptions key fallback =+ fromMaybe fallback (lookup key descriptions)++-- Map a Haskell type to its JSON schema type string+jsonTypeFor :: Type -> String+jsonTypeFor (ConT n)+ | nameBase n == "Int" = "integer"+ | nameBase n == "Integer" = "integer"+ | nameBase n == "Double" = "number"+ | nameBase n == "Float" = "number"+ | nameBase n == "Bool" = "boolean"+jsonTypeFor _ = "string"+ -- Helper function to convert Clause to Match clauseToMatch :: Clause -> Match clauseToMatch (Clause ps b ds) = Match (case ps of [p] -> p; _ -> TupP ps) b ds --- | Derive prompt handlers from a data type with custom descriptions--- Usage: $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")])+-- Get fields from a constructor: [] for nullary, record fields for RecC,+-- extracted fields for single-param NormalC+getConFields :: Con -> Q [(Name, Bang, Type)]+getConFields (NormalC _ []) = pure []+getConFields (RecC _ fields) = pure fields+getConFields (NormalC _ [(_bang, paramType)]) = extractFieldsFromParamType paramType+getConFields _ = fail "Unsupported constructor type"++-- Get the constructor name from a Con+conName :: Con -> Name+conName (NormalC n _) = n+conName (RecC n _) = n+conName (InfixC _ n _) = n+conName (ForallC _ _ c) = conName c+conName (GadtC (n:_) _ _) = n+conName (RecGadtC (n:_) _ _) = n+conName _ = error "conName: empty GADT constructor list"++-- Compute required field names (non-Maybe fields)+requiredFieldNames :: [(Name, Bang, Type)] -> [String]+requiredFieldNames fields =+ [ nameBase fn | (fn, _, ft) <- fields, not (fst (unwrapMaybe ft)) ]++-------------------------------------------------------------------------------+-- Prompt derivation+-------------------------------------------------------------------------------++-- | Derive prompt handlers from a data type with custom descriptions.+-- Usage:+--+-- > $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")]) derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp derivePromptHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate prompt definitions- promptDefs <- sequence $ map (mkPromptDefWithDescription descriptions) constructors+ promptDefs <- traverse (mkPromptDefWithDescription descriptions) constructors -- Generate list handler listHandlerExp <- [| pure $(return $ ListE promptDefs) |] -- Generate get handler with cases- cases <- sequence $ map (mkPromptCase handlerName) constructors+ cases <- traverse (mkDispatchCase handlerName) constructors defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |] let defaultMatch = Match WildP (NormalB defaultCase) []-- getHandlerExp <- return $ LamE [VarP (mkName "name"), VarP (mkName "args")] $- CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))- (map clauseToMatch cases ++ [defaultMatch])+ let getHandlerExp = LamE [VarP (mkName "name"), VarP (mkName "args")] $+ CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))+ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just getHandlerExp] _ -> fail $ "derivePromptHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive prompt handlers from a data type--- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)+-- | Derive prompt handlers from a data type.+-- Usage:+--+-- > $(derivePromptHandler ''MyPrompt 'handlePrompt) derivePromptHandler :: Name -> Name -> Q Exp derivePromptHandler typeName handlerName = derivePromptHandlerWithDescription typeName handlerName [] mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp-mkPromptDefWithDescription descriptions con =- case con of- NormalC name [] -> do- let promptName = T.pack . toSnakeCase . nameBase $ name- let constructorName = nameBase name- let description = case lookup constructorName descriptions of- Just desc -> desc- Nothing -> "Handle " ++ constructorName- [| PromptDefinition- { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)- , promptDefinitionDescription = $(litE $ stringL description)- , promptDefinitionArguments = []- , promptDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- RecC name fields -> do- 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 <- sequence $ map (mkArgDef descriptions) fields- [| PromptDefinition- { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)- , promptDefinitionDescription = $(litE $ stringL description)- , promptDefinitionArguments = $(return $ ListE args)- , promptDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- 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)- , promptDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- _ -> fail "Unsupported constructor type"+mkPromptDefWithDescription descriptions con = do+ let name = conName con+ let sname = snakeName name+ let description = descriptionFor descriptions (nameBase name) ("Handle " ++ nameBase name)+ args <- case con of+ NormalC _ [] -> pure []+ RecC _ fields -> traverse (mkArgDef descriptions) fields+ NormalC _ [(_bang, paramType)] -> extractFieldsFromType descriptions paramType+ _ -> fail "Unsupported constructor type"+ [| PromptDefinition+ { promptDefinitionName = $(litE $ stringL sname)+ , promptDefinitionDescription = $(litE $ stringL description)+ , promptDefinitionArguments = $(return $ ListE args)+ , promptDefinitionTitle = Nothing+ } |] -- Extract field definitions from a parameter type recursively extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp]@@ -115,10 +151,10 @@ ConT typeName -> do info <- reify typeName case info of- TyConI (DataD _ _ _ _ [RecC _ fields] _) -> do+ TyConI (DataD _ _ _ _ [RecC _ fields] _) -> -- Parameter type is a record with fields- sequence $ map (mkArgDef descriptions) fields- TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> do+ traverse (mkArgDef descriptions) fields+ TyConI (DataD _ _ _ _ [NormalC _ [(_bang, innerType)]] _) -> -- Parameter type has a single parameter - recurse extractFieldsFromType descriptions innerType _ -> fail $ "Parameter type " ++ show typeName ++ " must be a record type or single-parameter constructor"@@ -126,104 +162,104 @@ mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp mkArgDef descriptions (fieldName, _, fieldType) = do- let isOptional = case fieldType of- AppT (ConT n) _ -> nameBase n == "Maybe"- _ -> False+ let isOptional = fst (unwrapMaybe fieldType) let fieldNameStr = nameBase fieldName- let description = case lookup fieldNameStr descriptions of- Just desc -> desc- Nothing -> fieldNameStr+ let description = descriptionFor descriptions fieldNameStr fieldNameStr [| ArgumentDefinition { argumentDefinitionName = $(litE $ stringL fieldNameStr) , argumentDefinitionDescription = $(litE $ stringL description) , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) } |] -mkPromptCase :: Name -> Con -> Q Clause-mkPromptCase handlerName (NormalC name []) = do- let promptName = T.pack . toSnakeCase . nameBase $ name- clause [litP $ stringL $ T.unpack promptName]- (normalB [| do- content <- $(varE handlerName) $(conE name)- pure $ Right content |])- []-mkPromptCase handlerName (RecC name fields) = do- 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"+-------------------------------------------------------------------------------+-- Dispatch case generation (shared by prompt and tool)+------------------------------------------------------------------------------- -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+mkDispatchCase :: Name -> Con -> Q Clause+mkDispatchCase handlerName con = do+ let name = conName con+ let sname = snakeName name+ body <- case con of+ NormalC _ [] -> [| do- content <- $(varE handlerName') $(return outerConstructorApp)+ content <- $(varE handlerName) $(conE name) pure $ Right content |]+ RecC _ fields ->+ mkRecordCase name handlerName fields+ NormalC _ [(_bang, paramType)] ->+ mkSeparateParamsCase name handlerName paramType+ _ -> fail "Unsupported constructor type"+ clause [litP $ stringL sname] (normalB (return body)) [] - 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)+-------------------------------------------------------------------------------+-- Field validation+------------------------------------------------------------------------------- - continuation <- buildNestedFieldValidationWithConstructor outerConName handlerName' paramType' remainingFields (depth + 1)+mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp+mkSeparateParamsCase outerConName handlerName paramType = do+ fields <- extractFieldsFromParamType paramType+ let argMapName = mkName "argMap"+ let mkBaseExp fieldVars = do+ paramConstructorApp <- buildParameterConstructor paramType fieldVars+ let outerConstructorApp = AppE (ConE outerConName) paramConstructorApp+ [| do+ content <- $(varE handlerName) $(return outerConstructorApp)+ pure $ Right content |]+ inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0+ [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - -- 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+mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp+mkRecordCase recConName handlerName fields = do+ case fields of+ [] -> [| do+ content <- $(varE handlerName) $(conE recConName)+ pure $ Right content |]+ _ -> do+ let argMapName = mkName "argMap"+ let mkBaseExp fieldVars = do+ let constructorApp = foldl AppE (ConE recConName) (map VarE fieldVars)+ [| do+ content <- $(varE handlerName) $(return constructorApp)+ pure $ Right content |]+ inner <- buildFieldValidation argMapName handlerName mkBaseExp fields 0+ [| let $(varP argMapName) = Map.fromList args in $(return inner) |] - 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" |]+-- Build nested case expressions for field validation, supporting any number of fields.+-- The mkBaseExp callback receives field variable names and builds the final expression.+buildFieldValidation :: Name -> Name -> ([Name] -> Q Exp) -> [(Name, Bang, Type)] -> Int -> Q Exp+buildFieldValidation _argMap _handlerName mkBaseExp [] depth = do+ let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]]+ mkBaseExp fieldVars +buildFieldValidation argMap handlerName mkBaseExp ((fieldName, _, fieldType):remainingFields) depth = do+ let fieldStr = nameBase fieldName+ let (isOptional, innerType) = unwrapMaybe fieldType+ let fieldVar = mkName ("field" ++ show depth)++ continuation <- buildFieldValidation argMap handlerName mkBaseExp remainingFields (depth + 1)++ let parseFunc = mkParseFunc innerType++ let fieldPrefix = litE $ stringL $ "field '" <> fieldStr <> "': "++ if isOptional+ then do+ [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of+ Nothing -> do+ let $(varP fieldVar) = Nothing+ $(return continuation)+ Just raw -> case $(parseFunc) raw of+ Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err)+ Right parsed -> do+ let $(varP fieldVar) = Just parsed+ $(return continuation) |]+ else do+ [| case Map.lookup $(litE $ stringL fieldStr) $(varE argMap) of+ Just raw -> case $(parseFunc) raw of+ Left err -> pure $ Left $ InvalidParams ($fieldPrefix <> err)+ Right $(varP fieldVar) -> $(return continuation)+ Nothing -> pure $ Left $ MissingRequiredParams $(litE $ stringL $ "field '" <> fieldStr <> "' is missing") |]+ -- Extract field information from parameter type extractFieldsFromParamType :: Type -> Q [(Name, Bang, Type)] extractFieldsFromParamType paramType = do@@ -245,121 +281,66 @@ ConT typeName -> do info <- reify typeName case info of- TyConI (DataD _ _ _ _ [RecC conName _] _) -> do+ TyConI (DataD _ _ _ _ [RecC cn _] _) -> -- Record constructor - apply all field variables- return $ foldl AppE (ConE conName) (map VarE fieldVars)- TyConI (DataD _ _ _ _ [NormalC conName [(_bang, innerType)]] _) -> do+ return $ foldl AppE (ConE cn) (map VarE fieldVars)+ TyConI (DataD _ _ _ _ [NormalC cn [(_bang, innerType)]] _) -> do -- Single parameter constructor - recurse and wrap innerConstructor <- buildParameterConstructor innerType fieldVars- return $ AppE (ConE conName) innerConstructor+ return $ AppE (ConE cn) 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- [] -> [| do- content <- $(varE handlerName) $(conE conName)- pure $ Right content |]- _ -> do- -- Build nested case expressions for field validation- buildNestedFieldValidation conName handlerName fields 0---- Build nested case expressions for field validation, supporting any number of fields-buildNestedFieldValidation :: Name -> Name -> [(Name, Bang, Type)] -> Int -> Q Exp-buildNestedFieldValidation conName handlerName [] depth = do- -- Base case: all fields validated, build constructor application- let fieldVars = [mkName ("field" ++ show i) | i <- [0..depth-1]]- let constructorApp = foldl AppE (ConE conName) (map VarE fieldVars)- [| do- content <- $(varE handlerName) $(return constructorApp)- pure $ Right content |]--buildNestedFieldValidation conName handlerName ((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 <- buildNestedFieldValidation conName handlerName 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+-- Select the appropriate parse helper for a given type+mkParseFunc :: Type -> Q Exp+mkParseFunc innerType = case innerType of+ ConT n | nameBase n == "Int" -> [| parseInt |]+ ConT n | nameBase n == "Integer" -> [| parseInteger |]+ ConT n | nameBase n == "Double" -> [| parseDouble |]+ ConT n | nameBase n == "Float" -> [| parseFloat |]+ ConT n | nameBase n == "Bool" -> [| parseBool |]+ _ -> [| parseText |] - 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" |]+-------------------------------------------------------------------------------+-- Resource derivation+------------------------------------------------------------------------------- --- | Derive resource handlers from a data type with custom descriptions--- Usage: $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")])+-- | Derive resource handlers from a data type with custom descriptions.+-- Usage:+--+-- > $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")]) deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp deriveResourceHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate resource definitions- resourceDefs <- sequence $ map (mkResourceDefWithDescription descriptions) constructors-+ resourceDefs <- traverse (mkResourceDefWithDescription descriptions) constructors listHandlerExp <- [| pure $(return $ ListE resourceDefs) |] -- Generate read handler with cases- cases <- sequence $ map (mkResourceCase handlerName) constructors+ cases <- traverse (mkResourceCase handlerName) constructors defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |] let defaultMatch = Match (VarP (mkName "unknown")) (NormalB defaultCase) [] - readHandlerExp <- return $ LamE [VarP (mkName "uri")] $- CaseE (AppE (VarE 'show) (VarE (mkName "uri")))- (map clauseToMatch cases ++ [defaultMatch])+ let readHandlerExp = LamE [VarP (mkName "uri")] $+ CaseE (AppE (VarE 'show) (VarE (mkName "uri")))+ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just readHandlerExp] _ -> fail $ "deriveResourceHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive resource handlers from a data type--- Usage: $(deriveResourceHandler ''MyResource 'handleResource)+-- | Derive resource handlers from a data type.+-- Usage:+--+-- > $(deriveResourceHandler ''MyResource 'handleResource) deriveResourceHandler :: Name -> Name -> Q Exp deriveResourceHandler typeName handlerName = deriveResourceHandlerWithDescription typeName handlerName [] mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp mkResourceDefWithDescription descriptions (NormalC name []) = do- let resourceName = T.pack . toSnakeCase . nameBase $ name+ let resourceName = T.pack . snakeName $ name let resourceURI = "resource://" <> T.unpack resourceName let constructorName = nameBase name let description = case lookup constructorName descriptions of@@ -379,152 +360,75 @@ mkResourceCase :: Name -> Con -> Q Clause mkResourceCase handlerName (NormalC name []) = do- let resourceName = T.pack . toSnakeCase . nameBase $ name+ let resourceName = T.pack . snakeName $ name let resourceURI = "resource://" <> T.unpack resourceName clause [litP $ stringL resourceURI]- (normalB [| $(varE handlerName) $(varE (mkName "uri")) $(conE name) >>= pure . Right |])+ (normalB [| Right <$> $(varE handlerName) $(varE (mkName "uri")) $(conE name) |]) [] mkResourceCase _ _ = fail "Unsupported constructor type for resources" --- | Derive tool handlers from a data type with custom descriptions--- Usage: $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")])+-------------------------------------------------------------------------------+-- Tool derivation+-------------------------------------------------------------------------------++-- | Derive tool handlers from a data type with custom descriptions.+-- Usage:+--+-- > $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")]) deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp deriveToolHandlerWithDescription typeName handlerName descriptions = do info <- reify typeName case info of TyConI (DataD _ _ _ _ constructors _) -> do -- Generate tool definitions- toolDefs <- sequence $ map (mkToolDefWithDescription descriptions) constructors+ toolDefs <- traverse (mkToolDefWithDescription descriptions) constructors listHandlerExp <- [| pure $(return $ ListE toolDefs) |] -- Generate call handler with cases- cases <- sequence $ map (mkToolCase handlerName) constructors+ cases <- traverse (mkDispatchCase handlerName) constructors defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |] let defaultMatch = Match WildP (NormalB defaultCase) []-- callHandlerExp <- return $ LamE [VarP (mkName "name"), VarP (mkName "args")] $- CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))- (map clauseToMatch cases ++ [defaultMatch])+ let callHandlerExp = LamE [VarP (mkName "name"), VarP (mkName "args")] $+ CaseE (AppE (VarE 'T.unpack) (VarE (mkName "name")))+ (map clauseToMatch cases ++ [defaultMatch]) return $ TupE [Just listHandlerExp, Just callHandlerExp] _ -> fail $ "deriveToolHandlerWithDescription: " ++ show typeName ++ " is not a data type" --- | Derive tool handlers from a data type--- Usage: $(deriveToolHandler ''MyTool 'handleTool)+-- | Derive tool handlers from a data type.+-- Usage:+--+-- > $(deriveToolHandler ''MyTool 'handleTool) deriveToolHandler :: Name -> Name -> Q Exp deriveToolHandler typeName handlerName = deriveToolHandlerWithDescription typeName handlerName [] mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp-mkToolDefWithDescription descriptions con =- case con of- NormalC name [] -> do- let toolName = T.pack . toSnakeCase . nameBase $ name- let constructorName = nameBase name- let description = case lookup constructorName descriptions of- Just desc -> desc- Nothing -> constructorName- [| ToolDefinition- { toolDefinitionName = $(litE $ stringL $ T.unpack toolName)- , toolDefinitionDescription = $(litE $ stringL description)- , toolDefinitionInputSchema = InputSchemaDefinitionObject- { properties = []- , required = []- }- , toolDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- RecC name fields -> do- let toolName = T.pack . toSnakeCase . nameBase $ name- let constructorName = nameBase name- let description = case lookup constructorName descriptions of- Just desc -> desc- Nothing -> constructorName- 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)- }- , toolDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- 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)- }- , toolDefinitionTitle = Nothing -- 2025-06-18: New title field- } |]- _ -> fail "Unsupported constructor type for tools"-+mkToolDefWithDescription descriptions con = do+ let name = conName con+ let sname = snakeName name+ let description = descriptionFor descriptions (nameBase name) (nameBase name)+ fields <- getConFields con+ props <- traverse (mkProperty descriptions) fields+ let required = requiredFieldNames fields+ [| ToolDefinition+ { toolDefinitionName = $(litE $ stringL sname)+ , toolDefinitionDescription = $(litE $ stringL description)+ , toolDefinitionInputSchema = InputSchemaDefinitionObject+ { properties = $(return $ ListE props)+ , required = $(return $ ListE $ map (LitE . StringL) required)+ }+ , toolDefinitionTitle = Nothing+ } |] mkProperty :: [(String, String)] -> (Name, Bang, Type) -> Q Exp mkProperty descriptions (fieldName, _, fieldType) = do let fieldStr = nameBase fieldName- let description = case lookup fieldStr descriptions of- Just desc -> desc- Nothing -> fieldStr- let jsonType = case fieldType of- ConT n | nameBase n == "Int" -> "integer"- ConT n | nameBase n == "Integer" -> "integer"- ConT n | nameBase n == "Double" -> "number"- ConT n | nameBase n == "Float" -> "number"- ConT n | nameBase n == "Bool" -> "boolean"- AppT (ConT maybeType) innerType | nameBase maybeType == "Maybe" ->- case innerType of- ConT n | nameBase n == "Int" -> "integer"- ConT n | nameBase n == "Integer" -> "integer"- ConT n | nameBase n == "Double" -> "number"- ConT n | nameBase n == "Float" -> "number"- ConT n | nameBase n == "Bool" -> "boolean"- _ -> "string"- _ -> "string"+ let description = descriptionFor descriptions fieldStr fieldStr+ let (_, innerType) = unwrapMaybe fieldType+ let jsonType = jsonTypeFor innerType [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty { propertyType = $(litE $ stringL jsonType) , propertyDescription = $(litE $ stringL description) }) |]--mkToolCase :: Name -> Con -> Q Clause-mkToolCase handlerName (NormalC name []) = do- let toolName = T.pack . toSnakeCase . nameBase $ name- clause [litP $ stringL $ T.unpack toolName]- (normalB [| do- content <- $(varE handlerName) $(conE name)- pure $ Right content |])- []-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"
+ src/MCP/Server/Derive/Internal.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module MCP.Server.Derive.Internal+ ( parseText+ , parseInt+ , parseInteger+ , parseDouble+ , parseFloat+ , parseBool+ ) where++import Data.Text (Text)+import qualified Data.Text as T+import Text.Read (readMaybe)++parseText :: Text -> Either Text Text+parseText = Right++parseInt :: Text -> Either Text Int+parseInt t = case readMaybe (T.unpack t) of+ Just v -> Right v+ Nothing -> Left $ "Failed to parse Int from: " <> t++parseInteger :: Text -> Either Text Integer+parseInteger t = case readMaybe (T.unpack t) of+ Just v -> Right v+ Nothing -> Left $ "Failed to parse Integer from: " <> t++parseDouble :: Text -> Either Text Double+parseDouble t = case readMaybe (T.unpack t) of+ Just v -> Right v+ Nothing -> Left $ "Failed to parse Double from: " <> t++parseFloat :: Text -> Either Text Float+parseFloat t = case readMaybe (T.unpack t) of+ Just v -> Right v+ Nothing -> Left $ "Failed to parse Float from: " <> t++parseBool :: Text -> Either Text Bool+parseBool t = case T.toLower t of+ "true" -> Right True+ "false" -> Right False+ _ -> Left $ "Failed to parse Bool from: " <> t
test/HspecMain.hs view
@@ -9,6 +9,7 @@ import qualified Spec.AdvancedDerivation import qualified Spec.UnicodeHandling import qualified Spec.ProtocolVersionNegotiation+import qualified Spec.ToolCallParsing main :: IO () main = hspec $ do@@ -19,3 +20,4 @@ Spec.AdvancedDerivation.spec Spec.UnicodeHandling.spec Spec.ProtocolVersionNegotiation.spec+ Spec.ToolCallParsing.spec
+ test/Spec/ToolCallParsing.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Spec.ToolCallParsing (spec) where++import Data.Text (Text)+import qualified Data.Text as T+import MCP.Server+import MCP.Server.Derive+import Test.Hspec+import TestTypes++allTypesHandlers :: (ToolListHandler IO, ToolCallHandler IO)+allTypesHandlers = $(deriveToolHandler ''AllTypesTool 'handleAllTypesTool)++callTool :: Text -> [(Text, Text)] -> IO (Either Error Content)+callTool = snd allTypesHandlers++shouldBeRight :: IO (Either Error Content) -> Text -> IO ()+shouldBeRight action expected = do+ result <- action+ case result of+ Right (ContentText content) -> content `shouldBe` expected+ other -> expectationFailure $ "Expected ContentText '" ++ T.unpack expected ++ "' but got: " ++ show other++shouldBeInvalidParams :: IO (Either Error Content) -> Text -> IO ()+shouldBeInvalidParams action expectedSubstring = do+ result <- action+ case result of+ Left (InvalidParams msg) ->+ T.isInfixOf expectedSubstring msg `shouldBe` True+ other -> expectationFailure $ "Expected InvalidParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other++shouldBeMissingParams :: IO (Either Error Content) -> Text -> IO ()+shouldBeMissingParams action expectedSubstring = do+ result <- action+ case result of+ Left (MissingRequiredParams msg) ->+ T.isInfixOf expectedSubstring msg `shouldBe` True+ other -> expectationFailure $ "Expected MissingRequiredParams containing '" ++ T.unpack expectedSubstring ++ "' but got: " ++ show other++spec :: Spec+spec = describe "Tool call parsing" $ do++ describe "Required fields — successful parse" $ do+ it "parses all required field types" $+ shouldBeRight+ (callTool "required_fields"+ [ ("rfText", "hello")+ , ("rfInt", "42")+ , ("rfInteger", "100")+ , ("rfDouble", "3.14")+ , ("rfFloat", "2.5")+ , ("rfBool", "true")+ ])+ "text=hello, int=42, integer=100, double=3.14, float=2.5, bool=True"++ describe "Optional fields — present, successful parse" $ do+ it "parses all optional field types when present" $+ shouldBeRight+ (callTool "optional_fields"+ [ ("ofText", "world")+ , ("ofInt", "7")+ , ("ofInteger", "999")+ , ("ofDouble", "1.5")+ , ("ofFloat", "0.5")+ , ("ofBool", "false")+ ])+ "text=world, int=7, integer=999, double=1.5, float=0.5, bool=False"++ describe "Optional fields — missing" $ do+ it "handles all optional fields omitted" $+ shouldBeRight+ (callTool "optional_fields" [])+ "text=Nothing, int=Nothing, integer=Nothing, double=Nothing, float=Nothing, bool=Nothing"++ describe "Required fields — parse failure" $ do+ it "fails to parse Int from non-numeric string" $+ shouldBeInvalidParams+ (callTool "required_fields"+ [ ("rfText", "hello"), ("rfInt", "not_a_number"), ("rfInteger", "1")+ , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "true")+ ])+ "field 'rfInt': Failed to parse Int from: not_a_number"++ it "fails to parse Integer from non-numeric string" $+ shouldBeInvalidParams+ (callTool "required_fields"+ [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "nope")+ , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "true")+ ])+ "field 'rfInteger': Failed to parse Integer from: nope"++ it "fails to parse Double from non-numeric string" $+ shouldBeInvalidParams+ (callTool "required_fields"+ [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1")+ , ("rfDouble", "abc"), ("rfFloat", "1.0"), ("rfBool", "true")+ ])+ "field 'rfDouble': Failed to parse Double from: abc"++ it "fails to parse Float from non-numeric string" $+ shouldBeInvalidParams+ (callTool "required_fields"+ [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1")+ , ("rfDouble", "1.0"), ("rfFloat", "xyz"), ("rfBool", "true")+ ])+ "field 'rfFloat': Failed to parse Float from: xyz"++ it "fails to parse Bool from invalid string" $+ shouldBeInvalidParams+ (callTool "required_fields"+ [ ("rfText", "hello"), ("rfInt", "1"), ("rfInteger", "1")+ , ("rfDouble", "1.0"), ("rfFloat", "1.0"), ("rfBool", "maybe")+ ])+ "field 'rfBool': Failed to parse Bool from: maybe"++ describe "Optional fields — parse failure" $ do+ it "fails to parse optional Int from invalid value" $+ shouldBeInvalidParams+ (callTool "optional_fields" [("ofInt", "bad")])+ "field 'ofInt': Failed to parse Int from: bad"++ it "fails to parse optional Integer from invalid value" $+ shouldBeInvalidParams+ (callTool "optional_fields" [("ofInteger", "bad")])+ "field 'ofInteger': Failed to parse Integer from: bad"++ it "fails to parse optional Double from invalid value" $+ shouldBeInvalidParams+ (callTool "optional_fields" [("ofDouble", "bad")])+ "field 'ofDouble': Failed to parse Double from: bad"++ it "fails to parse optional Float from invalid value" $+ shouldBeInvalidParams+ (callTool "optional_fields" [("ofFloat", "bad")])+ "field 'ofFloat': Failed to parse Float from: bad"++ it "fails to parse optional Bool from invalid value" $+ shouldBeInvalidParams+ (callTool "optional_fields" [("ofBool", "bad")])+ "field 'ofBool': Failed to parse Bool from: bad"++ describe "Missing required field" $ do+ it "reports missing required field" $+ shouldBeMissingParams+ (callTool "required_fields" [("rfText", "hello")])+ "is missing"
test/TestTypes.hs view
@@ -92,6 +92,46 @@ handleRecursiveTool (ProcessData (MiddleParams (InnerParams name age))) = pure $ ContentText $ "Processing data for " <> name <> " (age " <> T.pack (show age) <> ")" +-- Type covering all parseable field types for exhaustive parsing tests+data AllTypesTool+ = RequiredFields+ { rfText :: Text+ , rfInt :: Int+ , rfInteger :: Integer+ , rfDouble :: Double+ , rfFloat :: Float+ , rfBool :: Bool+ }+ | OptionalFields+ { ofText :: Maybe Text+ , ofInt :: Maybe Int+ , ofInteger :: Maybe Integer+ , ofDouble :: Maybe Double+ , ofFloat :: Maybe Float+ , ofBool :: Maybe Bool+ }+ deriving (Show, Eq)++handleAllTypesTool :: AllTypesTool -> IO Content+handleAllTypesTool (RequiredFields t i ig d f b) =+ pure $ ContentText $ T.intercalate ", "+ [ "text=" <> t+ , "int=" <> T.pack (show i)+ , "integer=" <> T.pack (show ig)+ , "double=" <> T.pack (show d)+ , "float=" <> T.pack (show f)+ , "bool=" <> T.pack (show b)+ ]+handleAllTypesTool (OptionalFields t i ig d f b) =+ pure $ ContentText $ T.intercalate ", "+ [ "text=" <> maybe "Nothing" id t+ , "int=" <> maybe "Nothing" (T.pack . show) i+ , "integer=" <> maybe "Nothing" (T.pack . show) ig+ , "double=" <> maybe "Nothing" (T.pack . show) d+ , "float=" <> maybe "Nothing" (T.pack . show) f+ , "bool=" <> maybe "Nothing" (T.pack . show) b+ ]+ -- Test descriptions for custom description functionality testDescriptions :: [(String, String)] testDescriptions =