diff --git a/examples/TemplateHaskell.hs b/examples/TemplateHaskell.hs --- a/examples/TemplateHaskell.hs +++ b/examples/TemplateHaskell.hs @@ -28,6 +28,10 @@ Just cat -> pure $ ContentText $ "Search results for '" <> q <> "' in " <> cat <> ": Found 8 products" handleTool (AddToCart sku) = pure $ ContentText $ "Added item " <> sku <> " to your cart. Cart total: 3 items" handleTool Checkout = pure $ ContentText "Checkout completed! Order #12345 confirmed. Thank you for shopping with us!" +handleTool (ComplexTool field1 field2 field3 field4 field5) = + pure $ ContentText $ "Complex tool called with: " <> field1 <> ", " <> field2 <> + maybe "" (", " <>) field3 <> ", " <> field4 <> + maybe "" (", " <>) field5 main :: IO () main = do diff --git a/examples/Types.hs b/examples/Types.hs --- a/examples/Types.hs +++ b/examples/Types.hs @@ -21,4 +21,5 @@ = SearchForProduct { q :: Text, category :: Maybe Text } | AddToCart { sku :: Text } | Checkout + | ComplexTool { field1 :: Text, field2 :: Text, field3 :: Maybe Text, field4 :: Text, field5 :: Maybe Text } deriving (Show, Eq) 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.0 +version: 0.1.0.1 -- 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 @@ -14,165 +14,242 @@ import MCP.Server.Types +-- 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 -- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt) derivePromptHandler :: Name -> Name -> Q Exp derivePromptHandler typeName handlerName = do info <- reify typeName case info of - TyConI (DataD _ _ _ _ _constructors _) -> do - -- For now, return a basic working implementation + TyConI (DataD _ _ _ _ constructors _) -> do + -- Generate prompt definitions + promptDefs <- sequence $ map mkPromptDef constructors + + -- Generate list handler listHandlerExp <- [| \_cursor -> pure $ PaginatedResult - { paginatedItems = - [ PromptDefinition - { promptDefinitionName = "recipe" - , promptDefinitionDescription = "Generate a detailed recipe" - , promptDefinitionArguments = - [ ArgumentDefinition - { argumentDefinitionName = "idea" - , argumentDefinitionDescription = "Recipe idea" - , argumentDefinitionRequired = True - } - ] - } - , PromptDefinition - { promptDefinitionName = "shopping" - , promptDefinitionDescription = "Create a shopping list" - , promptDefinitionArguments = - [ ArgumentDefinition - { argumentDefinitionName = "description" - , argumentDefinitionDescription = "Shopping description" - , argumentDefinitionRequired = True - } - ] - } - ] + { paginatedItems = $(return $ ListE promptDefs) , paginatedNextCursor = Nothing } |] - - getHandlerExp <- [| \name args -> case T.unpack name of - "recipe" -> case Map.lookup "idea" (Map.fromList args) of - Nothing -> pure $ Left $ MissingRequiredParams "field 'idea' is missing" - Just idea -> do - content <- $(varE handlerName) (Recipe idea) - pure $ Right content - "shopping" -> case Map.lookup "description" (Map.fromList args) of - Nothing -> pure $ Left $ MissingRequiredParams "field 'description' is missing" - Just desc -> do - content <- $(varE handlerName) (Shopping desc) - pure $ Right content - _ -> pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |] - + + -- Generate get handler with cases + cases <- sequence $ map (mkPromptCase 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]) + return $ TupE [Just listHandlerExp, Just getHandlerExp] _ -> fail $ "derivePromptHandler: " ++ show typeName ++ " is not a data type" +mkPromptDef :: Con -> Q Exp +mkPromptDef (NormalC name []) = do + let promptName = T.toLower . T.pack . nameBase $ name + [| PromptDefinition + { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) + , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name) + , promptDefinitionArguments = [] + } |] +mkPromptDef (RecC name fields) = do + let promptName = T.toLower . T.pack . nameBase $ name + args <- sequence $ map mkArgDef fields + [| PromptDefinition + { promptDefinitionName = $(litE $ stringL $ T.unpack promptName) + , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name) + , promptDefinitionArguments = $(return $ ListE args) + } |] +mkPromptDef _ = fail "Unsupported constructor type" + +mkArgDef :: (Name, Bang, Type) -> Q Exp +mkArgDef (fieldName, _, fieldType) = do + let isOptional = case fieldType of + AppT (ConT n) _ -> nameBase n == "Maybe" + _ -> False + [| ArgumentDefinition + { argumentDefinitionName = $(litE $ stringL $ nameBase fieldName) + , argumentDefinitionDescription = $(litE $ stringL $ nameBase fieldName) + , argumentDefinitionRequired = $(if isOptional then [| False |] else [| True |]) + } |] + +mkPromptCase :: Name -> Con -> Q Clause +mkPromptCase handlerName (NormalC name []) = do + let promptName = T.toLower . T.pack . 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.toLower . T.pack . nameBase $ name + body <- mkRecordCase name handlerName fields + clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) [] +mkPromptCase _ _ = fail "Unsupported constructor type" + +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 = case fieldType of + AppT (ConT n) _ -> nameBase n == "Maybe" + _ -> False + let fieldVar = mkName ("field" ++ show depth) + + continuation <- buildNestedFieldValidation conName handlerName remainingFields (depth + 1) + + if isOptional + then [| do + let $(varP fieldVar) = Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) + $(return continuation) |] + else [| case Map.lookup $(litE $ stringL fieldStr) (Map.fromList args) of + Just $(varP fieldVar) -> $(return continuation) + Nothing -> pure $ Left $ MissingRequiredParams $ "field '" <> $(litE $ stringL fieldStr) <> "' is missing" |] + -- | Derive resource handlers from a data type -- Usage: $(deriveResourceHandler ''MyResource 'handleResource) deriveResourceHandler :: Name -> Name -> Q Exp deriveResourceHandler typeName handlerName = do info <- reify typeName case info of - TyConI (DataD _ _ _ _ _constructors _) -> do + TyConI (DataD _ _ _ _ constructors _) -> do + -- Generate resource definitions + resourceDefs <- sequence $ map mkResourceDef constructors + listHandlerExp <- [| \_cursor -> pure $ PaginatedResult - { paginatedItems = - [ ResourceDefinition - { resourceDefinitionURI = "resource://productcategories" - , resourceDefinitionName = "productcategories" - , resourceDefinitionDescription = Just "Product categories" - , resourceDefinitionMimeType = Just "text/plain" - } - , ResourceDefinition - { resourceDefinitionURI = "resource://saleitems" - , resourceDefinitionName = "saleitems" - , resourceDefinitionDescription = Just "Sale items" - , resourceDefinitionMimeType = Just "text/plain" - } - , ResourceDefinition - { resourceDefinitionURI = "resource://headlinebannerad" - , resourceDefinitionName = "headlinebannerad" - , resourceDefinitionDescription = Just "Headline banner ad" - , resourceDefinitionMimeType = Just "text/plain" - } - ] + { paginatedItems = $(return $ ListE resourceDefs) , paginatedNextCursor = Nothing } |] - readHandlerExp <- [| \uri -> case show uri of - "resource://productcategories" -> Right <$> $(varE handlerName) ProductCategories - "resource://saleitems" -> Right <$> $(varE handlerName) SaleItems - "resource://headlinebannerad" -> Right <$> $(varE handlerName) HeadlineBannerAd - unknown -> pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |] + -- Generate read handler with cases + cases <- sequence $ map (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]) return $ TupE [Just listHandlerExp, Just readHandlerExp] _ -> fail $ "deriveResourceHandler: " ++ show typeName ++ " is not a data type" +mkResourceDef :: Con -> Q Exp +mkResourceDef (NormalC name []) = do + let resourceName = T.toLower . T.pack . nameBase $ name + let resourceURI = "resource://" <> T.unpack resourceName + [| ResourceDefinition + { resourceDefinitionURI = $(litE $ stringL resourceURI) + , resourceDefinitionName = $(litE $ stringL $ T.unpack resourceName) + , resourceDefinitionDescription = Just $(litE $ stringL $ nameBase name) + , resourceDefinitionMimeType = Just "text/plain" + } |] +mkResourceDef _ = fail "Unsupported constructor type for resources" + +mkResourceCase :: Name -> Con -> Q Clause +mkResourceCase handlerName (NormalC name []) = do + let resourceName = T.toLower . T.pack . nameBase $ name + let resourceURI = "resource://" <> T.unpack resourceName + clause [litP $ stringL resourceURI] + (normalB [| Right <$> $(varE handlerName) $(conE name) |]) + [] +mkResourceCase _ _ = fail "Unsupported constructor type for resources" + -- | Derive tool handlers from a data type -- Usage: $(deriveToolHandler ''MyTool 'handleTool) deriveToolHandler :: Name -> Name -> Q Exp deriveToolHandler typeName handlerName = do info <- reify typeName case info of - TyConI (DataD _ _ _ _ _constructors _) -> do + TyConI (DataD _ _ _ _ constructors _) -> do + -- Generate tool definitions + toolDefs <- sequence $ map mkToolDef constructors + listHandlerExp <- [| \_cursor -> pure $ PaginatedResult - { paginatedItems = - [ ToolDefinition - { toolDefinitionName = "searchforproduct" - , toolDefinitionDescription = "Search for products" - , toolDefinitionInputSchema = InputSchemaDefinitionObject - { properties = - [ ("q", InputSchemaDefinitionProperty - { propertyType = "string" - , propertyDescription = "Search query" - }) - , ("category", InputSchemaDefinitionProperty - { propertyType = "string" - , propertyDescription = "Category filter" - }) - ] - , required = ["q"] - } - } - , ToolDefinition - { toolDefinitionName = "addtocart" - , toolDefinitionDescription = "Add item to cart" - , toolDefinitionInputSchema = InputSchemaDefinitionObject - { properties = - [ ("sku", InputSchemaDefinitionProperty - { propertyType = "string" - , propertyDescription = "Product SKU" - }) - ] - , required = ["sku"] - } - } - , ToolDefinition - { toolDefinitionName = "checkout" - , toolDefinitionDescription = "Complete checkout" - , toolDefinitionInputSchema = InputSchemaDefinitionObject - { properties = [] - , required = [] - } - } - ] + { paginatedItems = $(return $ ListE toolDefs) , paginatedNextCursor = Nothing } |] - callHandlerExp <- [| \name args -> case T.unpack name of - "searchforproduct" -> case Map.lookup "q" (Map.fromList args) of - Nothing -> pure $ Left $ MissingRequiredParams "field 'q' is missing" - Just q -> do - let category = Map.lookup "category" (Map.fromList args) - content <- $(varE handlerName) (SearchForProduct q category) - pure $ Right content - "addtocart" -> case Map.lookup "sku" (Map.fromList args) of - Nothing -> pure $ Left $ MissingRequiredParams "field 'sku' is missing" - Just sku -> do - content <- $(varE handlerName) (AddToCart sku) - pure $ Right content - "checkout" -> do - content <- $(varE handlerName) Checkout - pure $ Right content - _ -> pure $ Left $ UnknownTool $ "Unknown tool: " <> name |] + -- Generate call handler with cases + cases <- sequence $ map (mkToolCase 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]) return $ TupE [Just listHandlerExp, Just callHandlerExp] _ -> fail $ "deriveToolHandler: " ++ show typeName ++ " is not a data type" + +mkToolDef :: Con -> Q Exp +mkToolDef (NormalC name []) = do + let toolName = T.toLower . T.pack . nameBase $ name + [| ToolDefinition + { toolDefinitionName = $(litE $ stringL $ T.unpack toolName) + , toolDefinitionDescription = $(litE $ stringL $ nameBase name) + , toolDefinitionInputSchema = InputSchemaDefinitionObject + { properties = [] + , required = [] + } + } |] +mkToolDef (RecC name fields) = do + let toolName = T.toLower . T.pack . nameBase $ name + props <- sequence $ map mkProperty 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 $ nameBase name) + , toolDefinitionInputSchema = InputSchemaDefinitionObject + { properties = $(return $ ListE props) + , required = $(return $ ListE $ map (LitE . StringL) required) + } + } |] +mkToolDef _ = fail "Unsupported constructor type for tools" + +mkProperty :: (Name, Bang, Type) -> Q Exp +mkProperty (fieldName, _, _) = do + let fieldStr = nameBase fieldName + [| ($(litE $ stringL fieldStr), InputSchemaDefinitionProperty + { propertyType = "string" + , propertyDescription = $(litE $ stringL fieldStr) + }) |] + +mkToolCase :: Name -> Con -> Q Clause +mkToolCase handlerName (NormalC name []) = do + let toolName = T.toLower . T.pack . 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.toLower . T.pack . nameBase $ name + body <- mkRecordCase name handlerName fields + clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) [] +mkToolCase _ _ = fail "Unsupported constructor type for tools"