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

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

import qualified Data.Map            as Map
import qualified Data.Text           as T
import           Language.Haskell.TH

import           MCP.Server.Types

-- 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
-- Usage: $(derivePromptHandler ''MyPrompt 'handlePrompt)
derivePromptHandler :: Name -> Name -> Q Exp
derivePromptHandler :: Name -> Name -> Q Exp
derivePromptHandler Name
typeName Name
handlerName = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [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 Con -> Q Exp
mkPromptDef [Con]
constructors
      
      -- Generate list handler
      listHandlerExp <- [| \_cursor -> pure $ PaginatedResult
        { paginatedItems = $(return $ ListE promptDefs)
        , paginatedNextCursor = Nothing
        } |]
      
      -- 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
"derivePromptHandler: " 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"

mkPromptDef :: Con -> Q Exp
mkPromptDef :: Con -> Q Exp
mkPromptDef (NormalC Name
name []) = do
  let promptName :: Text
promptName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
  [| 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 -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
"Handle " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
name)
      , promptDefinitionArguments = []
      } |]
mkPromptDef (RecC Name
name [VarBangType]
fields) = do
  let promptName :: Text
promptName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
  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 VarBangType -> Q Exp
mkArgDef [VarBangType]
fields
  [| PromptDefinition
      { promptDefinitionName = $(litE $ stringL $ T.unpack promptName)
      , promptDefinitionDescription = $(litE $ stringL $ "Handle " ++ nameBase name)
      , promptDefinitionArguments = $(return $ ListE args)
      } |]
mkPromptDef Con
_ = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type"

mkArgDef :: (Name, Bang, Type) -> Q Exp
mkArgDef :: VarBangType -> Q Exp
mkArgDef (Name
fieldName, Bang
_, Kind
fieldType) = do
  let isOptional :: Bool
isOptional = case Kind
fieldType of
        AppT (ConT Name
n) Kind
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
        Kind
_ -> Bool
False
  [| 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 -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fieldName)
      , 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 -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fieldName)
      , 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 = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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 = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
_ Con
_ = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type"

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
_, Kind
fieldType):[VarBangType]
remainingFields) Int
depth = do
  let fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
  let isOptional :: Bool
isOptional = case Kind
fieldType of
        AppT (ConT Name
n) Kind
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
        Kind
_ -> Bool
False
  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)
  
  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 :: Name -> Name -> Q Exp
deriveResourceHandler Name
typeName Name
handlerName = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [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 Con -> Q Exp
mkResourceDef [Con]
constructors
      
      listHandlerExp <- [| \_cursor -> pure $ PaginatedResult
        { paginatedItems = $(return $ ListE resourceDefs)
        , paginatedNextCursor = Nothing
        } |]

      -- 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
"deriveResourceHandler: " 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"

mkResourceDef :: Con -> Q Exp
mkResourceDef :: Con -> Q Exp
mkResourceDef (NormalC Name
name []) = do
  let resourceName :: Text
resourceName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
  [| 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 = 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 -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name)
      , resourceDefinitionMimeType = Just "text/plain"
      } |]
mkResourceDef 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 = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
-- Usage: $(deriveToolHandler ''MyTool 'handleTool)
deriveToolHandler :: Name -> Name -> Q Exp
deriveToolHandler :: Name -> Name -> Q Exp
deriveToolHandler Name
typeName Name
handlerName = do
  info <- Name -> Q Info
reify Name
typeName
  case info of
    TyConI (DataD Cxt
_ Name
_ [TyVarBndr BndrVis]
_ Maybe Kind
_ [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 Con -> Q Exp
mkToolDef [Con]
constructors
      
      listHandlerExp <- [| \_cursor -> pure $ PaginatedResult
        { paginatedItems = $(return $ ListE toolDefs)
        , paginatedNextCursor = Nothing
        } |]

      -- 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
"deriveToolHandler: " 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"

mkToolDef :: Con -> Q Exp
mkToolDef :: Con -> Q Exp
mkToolDef (NormalC Name
name []) = do
  let toolName :: Text
toolName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
  [| 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 -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name)
      , toolDefinitionInputSchema = InputSchemaDefinitionObject
          { properties = []
          , required = []
          }
      } |]
mkToolDef (RecC Name
name [VarBangType]
fields) = do
  let toolName :: Text
toolName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
  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 VarBangType -> Q Exp
mkProperty [VarBangType]
fields
  requiredFields <- return $ map (\(Name
fieldName, Bang
_, Kind
fieldType) ->
    let isOptional :: Bool
isOptional = case Kind
fieldType of
          AppT (ConT Name
n) Kind
_ -> Name -> String
nameBase Name
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Maybe"
          Kind
_ -> 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 $ nameBase name)
      , toolDefinitionInputSchema = InputSchemaDefinitionObject
          { properties = $(return $ ListE props)
          , required = $(return $ ListE $ map (LitE . StringL) required)
          }
      } |]
mkToolDef 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 :: (Name, Bang, Type) -> Q Exp
mkProperty :: VarBangType -> Q Exp
mkProperty (Name
fieldName, Bang
_, Kind
_) = do
  let fieldStr :: String
fieldStr = Name -> String
nameBase Name
fieldName
  [| ($(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 = "string"
      , 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
fieldStr)
      }) |]

mkToolCase :: Name -> Con -> Q Clause
mkToolCase :: Name -> Con -> Q Clause
mkToolCase Name
handlerName (NormalC Name
name []) = do
  let toolName :: Text
toolName = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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 = Text -> Text
T.toLower (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Name -> String) -> Name -> Text
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
_ Con
_ = String -> Q Clause
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported constructor type for tools"