AdvancedDerivation.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}

module Spec.AdvancedDerivation (spec) where

import Control.Monad (forM_)
import Data.Text (Text)
import qualified Data.Text as T
import MCP.Server
import MCP.Server.Derive
import Test.Hspec
import TestTypes
import TestData

-- Generate advanced handlers for separate parameter types
testSeparateParamsToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)
testSeparateParamsToolHandlers = $(deriveToolHandler ''SeparateParamsTool 'handleSeparateParamsTool)

testRecursiveToolHandlers :: (ToolListHandler IO, ToolCallHandler IO)
testRecursiveToolHandlers = $(deriveToolHandler ''RecursiveTool 'handleRecursiveTool)

testSeparateParamsToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)
testSeparateParamsToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''SeparateParamsTool 'handleSeparateParamsTool separateParamsDescriptions)

testRecursiveToolHandlersWithDescriptions :: (ToolListHandler IO, ToolCallHandler IO)
testRecursiveToolHandlersWithDescriptions = $(deriveToolHandlerWithDescription ''RecursiveTool 'handleRecursiveTool separateParamsDescriptions)

-- Helper functions for advanced testing
findToolByName :: Text -> [ToolDefinition] -> ToolDefinition
findToolByName toolName toolDefs = 
  case filter (\def -> toolDefinitionName def == toolName) toolDefs of
    [def] -> def
    [] -> error $ "Tool not found: " ++ T.unpack toolName
    _ -> error $ "Multiple tools found with name: " ++ T.unpack toolName

assertSchemaHasProperties :: [Text] -> ToolDefinition -> IO ()
assertSchemaHasProperties expectedProps toolDef = do
  case toolDefinitionInputSchema toolDef of
    InputSchemaDefinitionObject props _ -> 
      let propNames = map fst props
      in all (`elem` propNames) expectedProps `shouldBe` True
    other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other

assertToolCallResult :: (ToolCallHandler IO) -> Text -> [(Text, Text)] -> Text -> IO ()
assertToolCallResult handler toolName args expectedContent = do
  result <- handler toolName args
  case result of
    Right (ContentText content) -> content `shouldBe` expectedContent
    other -> expectationFailure $ "Expected ContentText but got: " ++ show other

assertToolHasDescription :: Text -> Text -> ToolDefinition -> IO ()
assertToolHasDescription toolName expectedDesc toolDef = do
  toolDefinitionName toolDef `shouldBe` toolName
  toolDefinitionDescription toolDef `shouldBe` expectedDesc

assertPropertyHasDescription :: Text -> Text -> ToolDefinition -> IO ()
assertPropertyHasDescription propName expectedDesc toolDef = do
  case toolDefinitionInputSchema toolDef of
    InputSchemaDefinitionObject props _ -> 
      case lookup propName props of
        Just prop -> propertyDescription prop `shouldBe` expectedDesc
        Nothing -> expectationFailure $ "Property not found: " ++ T.unpack propName
    other -> expectationFailure $ "Expected InputSchemaDefinitionObject but got: " ++ show other

spec :: Spec
spec = describe "Advanced Template Haskell Derivation" $ do
  
  describe "Separate Parameter Types" $ do
    it "generates correct schema for separate parameter tools" $ do
      let (listHandler, _) = testSeparateParamsToolHandlers
      toolDefs <- listHandler
      
      -- Test GetValue tool schema
      let getValueDef = findToolByName "get_value" toolDefs
      assertSchemaHasProperties ["_gvpKey"] getValueDef
      
      -- Test SetValue tool schema  
      let setValueDef = findToolByName "set_value" toolDefs
      assertSchemaHasProperties ["_svpKey", "_svpValue"] setValueDef
    
    forM_ separateParamsTestCases $ \testCase ->
      it (T.unpack $ sepTestDescription testCase) $ do
        let (_, callHandler) = testSeparateParamsToolHandlers
        assertToolCallResult callHandler (sepToolName testCase) (sepArgs testCase) (sepExpectedResult testCase)

  describe "Recursive Parameter Types" $ do
    it "generates correct schema for recursive parameter tools" $ do
      let (listHandler, _) = testRecursiveToolHandlers
      toolDefs <- listHandler
      
      let processDataDef = findToolByName "process_data" toolDefs
      assertSchemaHasProperties ["_ipName", "_ipAge"] processDataDef
    
    forM_ recursiveParamsTestCases $ \testCase ->
      it (T.unpack $ recTestDescription testCase) $ do
        let (_, callHandler) = testRecursiveToolHandlers
        assertToolCallResult callHandler (recToolName testCase) (recArgs testCase) (recExpectedResult testCase)

  describe "Custom Descriptions with Separate Parameters" $ do
    it "applies correct tool descriptions for separate parameter tools" $ do
      let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions
      toolDefs <- listHandler
      
      let getValueDef = findToolByName "get_value" toolDefs
      assertToolHasDescription "get_value" "Retrieves a value from the key-value store" getValueDef
      
      let setValueDef = findToolByName "set_value" toolDefs
      assertToolHasDescription "set_value" "Sets a value in the key-value store" setValueDef
    
    it "applies correct field descriptions for separate parameter tools" $ do
      let (listHandler, _) = testSeparateParamsToolHandlersWithDescriptions
      toolDefs <- listHandler
      
      let getValueDef = findToolByName "get_value" toolDefs
      assertPropertyHasDescription "_gvpKey" "The key to retrieve the value for" getValueDef
      
      let setValueDef = findToolByName "set_value" toolDefs
      assertPropertyHasDescription "_svpKey" "The key to set the value for" setValueDef
      assertPropertyHasDescription "_svpValue" "The value to store" setValueDef

  describe "Recursive Tool Descriptions" $ do
    it "applies correct descriptions for recursive parameter tools" $ do
      let (listHandler, _) = testRecursiveToolHandlersWithDescriptions
      toolDefs <- listHandler
      
      let processDataDef = findToolByName "process_data" toolDefs
      assertToolHasDescription "process_data" "Processes user data with age validation" processDataDef
    
    it "applies correct field descriptions for recursive parameters" $ do
      let (listHandler, _) = testRecursiveToolHandlersWithDescriptions
      toolDefs <- listHandler
      
      let processDataDef = findToolByName "process_data" toolDefs
      assertPropertyHasDescription "_ipName" "The person's full name" processDataDef
      assertPropertyHasDescription "_ipAge" "The person's age in years" processDataDef