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

module MCP.Server.Derive
  ( -- * Template Haskell Derivation
    derivePromptHandler
  , derivePromptHandlerWithDescription
  , deriveResourceHandler
  , deriveResourceHandlerWithDescription
  , deriveToolHandler
  , deriveToolHandlerWithDescription
  ) where

import qualified Data.Map            as Map
import qualified Data.Text           as T
import           Language.Haskell.TH
import           Text.Read           (readMaybe)
import qualified Data.Char           as Char

import           MCP.Server.Types

-- Helper function to convert PascalCase/camelCase to snake_case
toSnakeCase :: String -> String
toSnakeCase :: String -> String
toSnakeCase [] = []
toSnakeCase (Char
x:String
xs) = Char -> Char
Char.toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
  where
    go :: String -> String
go [] = []
    go (Char
c:String
cs)
      | Char -> Bool
Char.isUpper Char
c = Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: Char -> Char
Char.toLower Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
cs
      | Bool
otherwise = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
cs

-- Helper function to convert Clause to Match
clauseToMatch :: Clause -> Match
clauseToMatch :: Clause -> Match
clauseToMatch (Clause [Pat]
ps Body
b [Dec]
ds) = Pat -> Body -> [Dec] -> Match
Match (case [Pat]
ps of [Pat
p] -> Pat
p; [Pat]
_ -> [Pat] -> Pat
TupP [Pat]
ps) Body
b [Dec]
ds

-- | Derive prompt handlers from a data type with custom descriptions
-- Usage: $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt [("Constructor", "Description")])
derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
derivePromptHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
derivePromptHandlerWithDescription Name
typeName Name
handlerName [(String, String)]
descriptions = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) -> do
      -- Generate prompt definitions
      promptDefs <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (Con -> Q Exp) -> [Con] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> Con -> Q Exp
mkPromptDefWithDescription [(String, String)]
descriptions) [Con]
constructors

      -- Generate list handler
      listHandlerExp <- [| pure $(return $ ListE promptDefs) |]

      -- Generate get handler with cases
      cases <- sequence $ map (mkPromptCase handlerName) constructors
      defaultCase <- [| pure $ Left $ InvalidPromptName $ "Unknown prompt: " <> name |]
      let defaultMatch = Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
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]
    Info
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"derivePromptHandlerWithDescription: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a data type"

-- | Derive prompt handlers from a data type
-- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)
derivePromptHandler :: Name -> Name -> Q Exp
derivePromptHandler :: Name -> Name -> Q Exp
derivePromptHandler Name
typeName Name
handlerName = 
  Name -> Name -> [(String, String)] -> Q Exp
derivePromptHandlerWithDescription Name
typeName Name
handlerName []

mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkPromptDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkPromptDefWithDescription [(String, String)]
descriptions Con
con = 
  case Con
con of
    NormalC Name
name [] -> do
      let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
"Handle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructorName
      [| PromptDefinition
          { promptDefinitionName = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
promptName)
          , promptDefinitionDescription = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
description)
          , promptDefinitionArguments = []
          } |]
    RecC Name
name [VarBangType]
fields -> do
      let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
"Handle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructorName
      args <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q Exp) -> [VarBangType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> VarBangType -> Q Exp
mkArgDef [(String, String)]
descriptions) [VarBangType]
fields
      [| PromptDefinition
          { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)
          , promptDefinitionDescription = $(litE $ stringL description)
          , promptDefinitionArguments = $(return $ ListE args)
          } |]
    NormalC Name
name [(Bang
_bang, Type
paramType)] -> do
      -- Handle separate parameter types approach
      let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
"Handle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
constructorName
      args <- [(String, String)] -> Type -> Q [Exp]
extractFieldsFromType [(String, String)]
descriptions Type
paramType
      [| PromptDefinition
          { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)
          , promptDefinitionDescription = $(litE $ stringL description)
          , promptDefinitionArguments = $(return $ ListE args)
          } |]
    Con
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type"

-- Extract field definitions from a parameter type recursively
extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp]
extractFieldsFromType :: [(String, String)] -> Type -> Q [Exp]
extractFieldsFromType [(String, String)]
descriptions Type
paramType = do
  case Type
paramType of
    ConT Name
typeName -> do
      info <- Name -> Q Info
reify Name
typeName
      case info of
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [RecC Name
_ [VarBangType]
fields] [DerivClause]
_) -> do
          -- Parameter type is a record with fields
          [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q Exp) -> [VarBangType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> VarBangType -> Q Exp
mkArgDef [(String, String)]
descriptions) [VarBangType]
fields
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [NormalC Name
_ [(Bang
_bang, Type
innerType)]] [DerivClause]
_) -> do
          -- Parameter type has a single parameter - recurse
          [(String, String)] -> Type -> Q [Exp]
extractFieldsFromType [(String, String)]
descriptions Type
innerType
        Info
_ -> String -> Q [Exp]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Exp]) -> String -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ String
"Parameter type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be a record type or single-parameter constructor"
    Type
_ -> String -> Q [Exp]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Exp]) -> String -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ String
"Parameter type must be a concrete type, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
paramType

mkArgDef :: [(String, String)] -> (Name, Bang, Type) -> Q Exp
mkArgDef :: [(String, String)] -> VarBangType -> Q Exp
mkArgDef [(String, String)]
descriptions (Name
fieldName, Bang
_, Type
fieldType) = do
  let isOptional :: Bool
isOptional = case Type
fieldType of
        AppT (ConT Name
n) Type
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
        Type
_               -> Bool
False
  let fieldNameStr :: String
fieldNameStr = Name -> String
nameBase Name
fieldName
  let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
fieldNameStr [(String, String)]
descriptions of
        Just String
desc -> String
desc
        Maybe String
Nothing   -> String
fieldNameStr
  [| ArgumentDefinition
      { argumentDefinitionName = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
fieldNameStr)
      , argumentDefinitionDescription = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
description)
      , argumentDefinitionRequired = $(if Bool
isOptional then [| False |] else [| True |])
      } |]

mkPromptCase :: Name -> Con -> Q Clause
mkPromptCase :: Name -> Con -> Q Clause
mkPromptCase Name
handlerName (NormalC Name
name []) = do
  let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> Q Pat) -> Lit -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
promptName]
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| do
        content <- $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handlerName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name)
        pure $ Right content |])
    []
mkPromptCase Name
handlerName (RecC Name
name [VarBangType]
fields) = do
  let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  body <- Name -> Name -> [VarBangType] -> Q Exp
mkRecordCase Name
name Name
handlerName [VarBangType]
fields
  clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) []
mkPromptCase Name
handlerName (NormalC Name
name [(Bang
_bang, Type
paramType)]) = do
  let promptName :: Text
promptName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  body <- Name -> Name -> Type -> Q Exp
mkSeparateParamsCase Name
name Name
handlerName Type
paramType
  clause [litP $ stringL $ T.unpack promptName] (normalB (return body)) []
mkPromptCase Name
_ Con
_ = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type"

mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp
mkSeparateParamsCase :: Name -> Name -> Type -> Q Exp
mkSeparateParamsCase Name
conName Name
handlerName Type
paramType = do
  fields <- Type -> Q [VarBangType]
extractFieldsFromParamType Type
paramType
  buildNestedFieldValidationWithConstructor conName handlerName paramType fields 0
  where
    buildNestedFieldValidationWithConstructor :: Name -> Name -> Type -> [(Name, Bang, Type)] -> Int -> Q Exp
    buildNestedFieldValidationWithConstructor :: Name -> Name -> Type -> [VarBangType] -> Int -> Q Exp
buildNestedFieldValidationWithConstructor Name
outerConName Name
handlerName' Type
paramType' [] Int
depth = do
      -- Base case: all fields validated, build parameter constructor hierarchy and outer constructor
      let fieldVars :: [Name]
fieldVars = [String -> Name
mkName (String
"field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
0..Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
      paramConstructorApp <- Type -> [Name] -> Q Exp
buildParameterConstructor Type
paramType' [Name]
fieldVars
      let outerConstructorApp = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
outerConName) Exp
paramConstructorApp
      [| do
          content <- $(varE handlerName') $(return outerConstructorApp)
          pure $ Right content |]
    
    buildNestedFieldValidationWithConstructor Name
outerConName Name
handlerName' Type
paramType' ((Name
fieldName, Bang
_, Type
fieldType):[VarBangType]
remainingFields) Int
depth = do
      let fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
      let (Bool
isOptional, Type
innerType) = case Type
fieldType of
            AppT (ConT Name
n) Type
inner | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe" -> (Bool
True, Type
inner)
            Type
other                                       -> (Bool
False, Type
other)
      let fieldVar :: Name
fieldVar = String -> Name
mkName (String
"field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
depth)

      continuation <- Name -> Name -> Type -> [VarBangType] -> Int -> Q Exp
buildNestedFieldValidationWithConstructor Name
outerConName Name
handlerName' Type
paramType' [VarBangType]
remainingFields (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

      -- Generate conversion expression based on type
      let convertExpr Name
rawVar = case Type
innerType of
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int" ->
              [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
                   Just parsed -> parsed
                   Nothing -> error $ "Failed to parse Int from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" ->
              [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
                   Just parsed -> parsed
                   Nothing -> error $ "Failed to parse Integer from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Double" ->
              [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
                   Just parsed -> parsed
                   Nothing -> error $ "Failed to parse Double from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Float" ->
              [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
                   Just parsed -> parsed
                   Nothing -> error $ "Failed to parse Float from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Bool" ->
              [| case T.toLower $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) of
                   "true" -> True
                   "false" -> False
                   _ -> error $ "Failed to parse Bool from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
            Type
_ -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
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 :: Type -> Q [VarBangType]
extractFieldsFromParamType Type
paramType = do
  case Type
paramType of
    ConT Name
typeName -> do
      info <- Name -> Q Info
reify Name
typeName
      case info of
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [RecC Name
_ [VarBangType]
fields] [DerivClause]
_) -> 
          [VarBangType] -> Q [VarBangType]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [VarBangType]
fields
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [NormalC Name
_ [(Bang
_bang, Type
innerType)]] [DerivClause]
_) -> 
          Type -> Q [VarBangType]
extractFieldsFromParamType Type
innerType
        Info
_ -> String -> Q [VarBangType]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [VarBangType]) -> String -> Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ String
"Parameter type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be a record type or single-parameter constructor"
    Type
_ -> String -> Q [VarBangType]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [VarBangType]) -> String -> Q [VarBangType]
forall a b. (a -> b) -> a -> b
$ String
"Parameter type must be a concrete type, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
paramType

-- Build the parameter constructor application recursively
buildParameterConstructor :: Type -> [Name] -> Q Exp
buildParameterConstructor :: Type -> [Name] -> Q Exp
buildParameterConstructor Type
paramType [Name]
fieldVars = do
  case Type
paramType of
    ConT Name
typeName -> do
      info <- Name -> Q Info
reify Name
typeName
      case info of
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [RecC Name
conName [VarBangType]
_] [DerivClause]
_) -> do
          -- Record constructor - apply all field variables
          Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
fieldVars)
        TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [NormalC Name
conName [(Bang
_bang, Type
innerType)]] [DerivClause]
_) -> do
          -- Single parameter constructor - recurse and wrap
          innerConstructor <- Type -> [Name] -> Q Exp
buildParameterConstructor Type
innerType [Name]
fieldVars
          return $ AppE (ConE conName) innerConstructor
        Info
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Parameter type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" must be a record type or single-parameter constructor"
    Type
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Parameter type must be a concrete type, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
paramType

mkRecordCase :: Name -> Name -> [(Name, Bang, Type)] -> Q Exp
mkRecordCase :: Name -> Name -> [VarBangType] -> Q Exp
mkRecordCase Name
conName Name
handlerName [VarBangType]
fields = do
  case [VarBangType]
fields of
    [] -> [| do
        content <- $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handlerName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conName)
        pure $ Right content |]
    [VarBangType]
_ -> do
      -- Build nested case expressions for field validation
      Name -> Name -> [VarBangType] -> Int -> Q Exp
buildNestedFieldValidation Name
conName Name
handlerName [VarBangType]
fields Int
0

-- Build nested case expressions for field validation, supporting any number of fields
buildNestedFieldValidation :: Name -> Name -> [(Name, Bang, Type)] -> Int -> Q Exp
buildNestedFieldValidation :: Name -> Name -> [VarBangType] -> Int -> Q Exp
buildNestedFieldValidation Name
conName Name
handlerName [] Int
depth = do
  -- Base case: all fields validated, build constructor application
  let fieldVars :: [Name]
fieldVars = [String -> Name
mkName (String
"field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
0..Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]]
  let constructorApp :: Exp
constructorApp = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
fieldVars)
  [| do
      content <- $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handlerName) $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
constructorApp)
      pure $ Right content |]

buildNestedFieldValidation Name
conName Name
handlerName ((Name
fieldName, Bang
_, Type
fieldType):[VarBangType]
remainingFields) Int
depth = do
  let fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
  let (Bool
isOptional, Type
innerType) = case Type
fieldType of
        AppT (ConT Name
n) Type
inner | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe" -> (Bool
True, Type
inner)
        Type
other                                       -> (Bool
False, Type
other)
  let fieldVar :: Name
fieldVar = String -> Name
mkName (String
"field" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
depth)

  continuation <- Name -> Name -> [VarBangType] -> Int -> Q Exp
buildNestedFieldValidation Name
conName Name
handlerName [VarBangType]
remainingFields (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

  -- Generate conversion expression based on type
  let convertExpr Name
rawVar = case Type
innerType of
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int" ->
          [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
               Just parsed -> parsed
               Nothing -> error $ "Failed to parse Int from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" ->
          [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
               Just parsed -> parsed
               Nothing -> error $ "Failed to parse Integer from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Double" ->
          [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
               Just parsed -> parsed
               Nothing -> error $ "Failed to parse Double from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Float" ->
          [| case readMaybe (T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar)) of
               Just parsed -> parsed
               Nothing -> error $ "Failed to parse Float from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Bool" ->
          [| case T.toLower $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) of
               "true" -> True
               "false" -> False
               _ -> error $ "Failed to parse Bool from: " <> T.unpack $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rawVar) |]
        Type
_ -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
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" |]

-- | Derive resource handlers from a data type with custom descriptions
-- Usage: $(deriveResourceHandlerWithDescription ''MyResource 'handleResource [("Constructor", "Description")])
deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
deriveResourceHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
deriveResourceHandlerWithDescription Name
typeName Name
handlerName [(String, String)]
descriptions = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) -> do
      -- Generate resource definitions
      resourceDefs <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (Con -> Q Exp) -> [Con] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> Con -> Q Exp
mkResourceDefWithDescription [(String, String)]
descriptions) [Con]
constructors

      listHandlerExp <- [| pure $(return $ ListE resourceDefs) |]

      -- Generate read handler with cases
      cases <- sequence $ map (mkResourceCase handlerName) constructors
      defaultCase <- [| pure $ Left $ ResourceNotFound $ "Resource not found: " <> T.pack unknown |]
      let defaultMatch = Pat -> Body -> [Dec] -> Match
Match (Name -> Pat
VarP (String -> Name
mkName String
"unknown")) (Exp -> Body
NormalB Exp
defaultCase) []

      readHandlerExp <- return $ LamE [VarP (mkName "uri")] $
        CaseE (AppE (VarE 'show) (VarE (mkName "uri")))
          (map clauseToMatch cases ++ [defaultMatch])

      return $ TupE [Just listHandlerExp, Just readHandlerExp]
    Info
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"deriveResourceHandlerWithDescription: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a data type"

-- | Derive resource handlers from a data type
-- Usage: $(deriveResourceHandler ''MyResource 'handleResource)
deriveResourceHandler :: Name -> Name -> Q Exp
deriveResourceHandler :: Name -> Name -> Q Exp
deriveResourceHandler Name
typeName Name
handlerName = 
  Name -> Name -> [(String, String)] -> Q Exp
deriveResourceHandlerWithDescription Name
typeName Name
handlerName []

mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkResourceDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkResourceDefWithDescription [(String, String)]
descriptions (NormalC Name
name []) = do
  let resourceName :: Text
resourceName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  let resourceURI :: String
resourceURI = String
"resource://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
resourceName
  let constructorName :: String
constructorName = Name -> String
nameBase Name
name
  let description :: Maybe String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
        Just String
desc -> String -> Maybe String
forall a. a -> Maybe a
Just String
desc
        Maybe String
Nothing   -> String -> Maybe String
forall a. a -> Maybe a
Just String
constructorName
  [| ResourceDefinition
      { resourceDefinitionURI = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
resourceURI)
      , resourceDefinitionName = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
resourceName)
      , resourceDefinitionDescription = $(case Maybe String
description of
          Just String
desc -> [| Just $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
desc) |]
          Maybe String
Nothing   -> [| Nothing |])
      , resourceDefinitionMimeType = Just "text/plain"
      } |]
mkResourceDefWithDescription [(String, String)]
_ Con
_ = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type for resources"


mkResourceCase :: Name -> Con -> Q Clause
mkResourceCase :: Name -> Con -> Q Clause
mkResourceCase Name
handlerName (NormalC Name
name []) = do
  let resourceName :: Text
resourceName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  let resourceURI :: String
resourceURI = String
"resource://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
resourceName
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> Q Pat) -> Lit -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
resourceURI]
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| Right <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handlerName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) |])
    []
mkResourceCase Name
_ Con
_ = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type for resources"

-- | Derive tool handlers from a data type with custom descriptions
-- Usage: $(deriveToolHandlerWithDescription ''MyTool 'handleTool [("Constructor", "Description")])
deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
deriveToolHandlerWithDescription :: Name -> Name -> [(String, String)] -> Q Exp
deriveToolHandlerWithDescription Name
typeName Name
handlerName [(String, String)]
descriptions = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
constructors [DerivClause]
_) -> do
      -- Generate tool definitions
      toolDefs <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (Con -> Q Exp) -> [Con] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> Con -> Q Exp
mkToolDefWithDescription [(String, String)]
descriptions) [Con]
constructors

      listHandlerExp <- [| pure $(return $ ListE toolDefs) |]

      -- Generate call handler with cases
      cases <- sequence $ map (mkToolCase handlerName) constructors
      defaultCase <- [| pure $ Left $ UnknownTool $ "Unknown tool: " <> name |]
      let defaultMatch = Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
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]
    Info
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"deriveToolHandlerWithDescription: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a data type"

-- | Derive tool handlers from a data type
-- Usage: $(deriveToolHandler ''MyTool 'handleTool)
deriveToolHandler :: Name -> Name -> Q Exp
deriveToolHandler :: Name -> Name -> Q Exp
deriveToolHandler Name
typeName Name
handlerName = 
  Name -> Name -> [(String, String)] -> Q Exp
deriveToolHandlerWithDescription Name
typeName Name
handlerName []

mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkToolDefWithDescription :: [(String, String)] -> Con -> Q Exp
mkToolDefWithDescription [(String, String)]
descriptions Con
con = 
  case Con
con of
    NormalC Name
name [] -> do
      let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
constructorName
      [| ToolDefinition
          { toolDefinitionName = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
toolName)
          , toolDefinitionDescription = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
description)
          , toolDefinitionInputSchema = InputSchemaDefinitionObject
              { properties = []
              , required = []
              }
          } |]
    RecC Name
name [VarBangType]
fields -> do
      let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
constructorName
      props <- [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Q Exp] -> Q [Exp]) -> [Q Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q Exp) -> [VarBangType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([(String, String)] -> VarBangType -> Q Exp
mkProperty [(String, String)]
descriptions) [VarBangType]
fields
      requiredFields <- return $ map (\(Name
fieldName, Bang
_, Type
fieldType) ->
        let isOptional :: Bool
isOptional = case Type
fieldType of
              AppT (ConT Name
n) Type
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
              Type
_               -> Bool
False
        in if Bool
isOptional then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just (Name -> String
nameBase Name
fieldName)
        ) fields
      let required = [String
f | Just String
f <- [Maybe String]
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)
              }
          } |]
    NormalC Name
name [(Bang
_bang, Type
paramType)] -> do
      -- Handle separate parameter types approach for tools
      let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
      let constructorName :: String
constructorName = Name -> String
nameBase Name
name
      let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
constructorName [(String, String)]
descriptions of
            Just String
desc -> String
desc
            Maybe String
Nothing   -> String
constructorName
      fields <- Type -> Q [VarBangType]
extractFieldsFromParamType Type
paramType
      props <- sequence $ map (mkProperty descriptions) fields
      requiredFields <- return $ map (\(Name
fieldName, Bang
_, Type
fieldType) ->
        let isOptional :: Bool
isOptional = case Type
fieldType of
              AppT (ConT Name
n) Type
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
              Type
_               -> Bool
False
        in if Bool
isOptional then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just (Name -> String
nameBase Name
fieldName)
        ) fields
      let required = [String
f | Just String
f <- [Maybe String]
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)
              }
          } |]
    Con
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type for tools"


mkProperty :: [(String, String)] -> (Name, Bang, Type) -> Q Exp
mkProperty :: [(String, String)] -> VarBangType -> Q Exp
mkProperty [(String, String)]
descriptions (Name
fieldName, Bang
_, Type
fieldType) = do
  let fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
  let description :: String
description = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
fieldStr [(String, String)]
descriptions of
        Just String
desc -> String
desc
        Maybe String
Nothing   -> String
fieldStr
  let jsonType :: String
jsonType = case Type
fieldType of
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int" -> String
"integer"
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" -> String
"integer"
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Double" -> String
"number"
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Float" -> String
"number"
        ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Bool" -> String
"boolean"
        AppT (ConT Name
maybeType) Type
innerType | Name -> String
nameBase Name
maybeType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe" ->
          case Type
innerType of
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Int"     -> String
"integer"
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Integer" -> String
"integer"
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Double"  -> String
"number"
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Float"   -> String
"number"
            ConT Name
n | Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Bool"    -> String
"boolean"
            Type
_                                -> String
"string"
        Type
_ -> String
"string"
  [| ($(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
fieldStr), InputSchemaDefinitionProperty
      { propertyType = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
jsonType)
      , propertyDescription = $(Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> Lit -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL String
description)
      }) |]

mkToolCase :: Name -> Con -> Q Clause
mkToolCase :: Name -> Con -> Q Clause
mkToolCase Name
handlerName (NormalC Name
name []) = do
  let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Lit -> Q Pat
forall (m :: * -> *). Quote m => Lit -> m Pat
litP (Lit -> Q Pat) -> Lit -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
toolName]
    (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| do
        content <- $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handlerName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name)
        pure $ Right content |])
    []
mkToolCase Name
handlerName (RecC Name
name [VarBangType]
fields) = do
  let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  body <- Name -> Name -> [VarBangType] -> Q Exp
mkRecordCase Name
name Name
handlerName [VarBangType]
fields
  clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) []
mkToolCase Name
handlerName (NormalC Name
name [(Bang
_bang, Type
paramType)]) = do
  let toolName :: Text
toolName = String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toSnakeCase (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Name
name
  body <- Name -> Name -> Type -> Q Exp
mkSeparateParamsCase Name
name Name
handlerName Type
paramType
  clause [litP $ stringL $ T.unpack toolName] (normalB (return body)) []
mkToolCase Name
_ Con
_ = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type for tools"