diff --git a/lib/haskell/explainable/app/Main.hs b/lib/haskell/explainable/app/Main.hs index 763dae86d..d52360081 100644 --- a/lib/haskell/explainable/app/Main.hs +++ b/lib/haskell/explainable/app/Main.hs @@ -1,32 +1,16 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeOperators #-} module Main (main) where -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Except -import Data.Aeson (FromJSON, ToJSON, (.=)) -import Data.Aeson qualified as Aeson -import Data.Aeson.Types qualified as Aeson -import Data.HashMap.Strict qualified as HashMap -import Data.Map qualified as Map -import Data.Scientific (toRealFloat) -import Data.String.Interpolate (__i) -import Data.Text qualified as Text -import Explainable.MathLang -import GHC.Generics import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Logger import Options -import Options.Applicative +import Options.Applicative as Opts +import Schema import Servant -import System.Timeout (timeout) +import Servant.Swagger.UI (SwaggerSchemaUI, swaggerSchemaUIServer) +import Server -- ---------------------------------------------------------------------------- -- Option Parser @@ -34,54 +18,13 @@ import System.Timeout (timeout) opts :: ParserInfo Options opts = - info + Opts.info (optionsParser <**> helper) ( fullDesc <> progDesc "Serve a Web Service for interacting with a MathLang evaluator" <> header "explainable - A web server for MathLang" ) --- ---------------------------------------------------------------------------- --- Servant API --- ---------------------------------------------------------------------------- - -type Api = FunctionApi - -type FunctionApi = - "functions" - :> (Functions :<|> FunctionsCrud) - -type Functions = Get '[JSON] [SimpleFunction] - -type FunctionsCrud = - Capture "name" String - :> ( ReqBody '[JSON] Attributes :> Post '[JSON] SimpleResponse - :<|> Get '[JSON] Function - ) - -data FlatValue - = Number Double - | Boolean Bool - deriving (Show, Read, Ord, Eq, Generic) - -instance FromJSON FlatValue where - parseJSON (Aeson.Number sci) = pure $ Number $ toRealFloat sci - parseJSON (Aeson.Bool b) = pure $ Boolean b - parseJSON o = - Aeson.parseFail $ "Unexpected value, expected Number or Bool but got: " <> show o - -newtype Attributes = Attributes - { mkAttributes :: Map.Map String FlatValue - } - deriving (Show, Read, Ord, Eq, Generic) - deriving newtype (FromJSON) - -data SimpleResponse - = SimpleResponse Double - | Insufficient String - deriving (Show, Read, Ord, Eq, Generic) - deriving anyclass (FromJSON, ToJSON) - -- ---------------------------------------------------------------------------- -- Main Application and wiring -- ---------------------------------------------------------------------------- @@ -93,180 +36,14 @@ main = do let settings = setPort port $ setLogger aplogger defaultSettings runSettings settings app -app :: Application -app = serve (Proxy @Api) handler - --- ---------------------------------------------------------------------------- --- Web Service Handlers --- ---------------------------------------------------------------------------- - -handler :: Server Api -handler = - handlerFunctions - :<|> ( \name -> - handlerFunction name - :<|> handlerParameters name - ) - -handlerFunctions :: Handler [SimpleFunction] -handlerFunctions = do - pure $ fmap (toSimpleFunction . snd) $ Map.elems functions - where - toSimpleFunction s = - SimpleFunction - { simpleName = name s - , simpleDescription = description s - } - -handlerFunction :: String -> Attributes -> Handler SimpleResponse -handlerFunction name query = do - case Map.lookup name functions of - Nothing -> throwError err404 - Just (scenario, _) -> - case runExcept $ fromParams query of - Left err -> - pure $ Insufficient err - Right s -> do - response <- timeoutAction $ runScenario s scenario - pure $ SimpleResponse response +type ApiWithSwagger = + SwaggerSchemaUI "swagger-ui" "swagger.json" + :<|> Api -handlerParameters :: String -> Handler Function -handlerParameters name = case Map.lookup name functions of - Nothing -> throwError err404 - Just (_, scenario) -> pure scenario +appWithSwagger :: Servant.Server ApiWithSwagger +appWithSwagger = + swaggerSchemaUIServer serverOpenApi + :<|> handler -timeoutAction :: IO b -> Handler b -timeoutAction act = - liftIO (timeout (seconds 5) act) >>= \case - Nothing -> throwError err505 - Just r -> pure r - where - seconds n = 1_000_000 * n - --- ---------------------------------------------------------------------------- --- API specification for LLMs --- ---------------------------------------------------------------------------- - -data SimpleFunction = SimpleFunction - { simpleName :: Text.Text - , simpleDescription :: Text.Text - } - deriving (Show, Read, Ord, Eq, Generic) - -data Function = Function - { name :: Text.Text - , description :: Text.Text - , parameters :: Parameters - } - deriving (Show, Read, Ord, Eq, Generic) - -newtype Parameters = Parameters Properties - deriving (Show, Read, Ord, Eq, Generic) - -instance ToJSON SimpleFunction where - toJSON (SimpleFunction n desc) = - Aeson.object - [ "type" .= Aeson.String "function" - , "function" - .= Aeson.object - [ "name" .= Aeson.String n - , "description" .= Aeson.String desc - ] - ] - -instance ToJSON Function where - toJSON (Function n desc params) = - Aeson.object - [ "type" .= Aeson.String "function" - , "function" - .= Aeson.object - [ "name" .= Aeson.String n - , "description" .= Aeson.String desc - , "parameters" .= params - ] - ] - -instance ToJSON Parameters where - toJSON (Parameters props) = - Aeson.object - [ "type" .= Aeson.String "object" - , "properties" .= props - ] - -newtype Properties = Properties - { mkProperties :: Map.Map String Parameter - } - deriving (Show, Read, Ord, Eq, Generic) - deriving newtype (ToJSON) - -data Parameter = Parameter - { parameterType :: String - , parameterEnum :: [String] - , parameterDescription :: String - } - deriving (Show, Read, Ord, Eq, Generic) - -instance ToJSON Parameter where - toJSON (Parameter ty enum desc) = - Aeson.object - [ "type" .= ty - , "enum" .= enum - , "description" .= desc - ] - --- ---------------------------------------------------------------------------- --- Example Rules --- ---------------------------------------------------------------------------- - -runScenario :: (MonadIO m) => MyState -> Expr Double -> m Double -runScenario s scenario = do - (res, _, _, _) <- liftIO $ xplainF () s scenario - pure res - -fromParams :: Attributes -> Except String MyState -fromParams attrs = do - let (valueMap, predMap) = Map.mapEither go (mkAttributes attrs) - pure $ - emptyState - { symtabF = HashMap.fromList $ Map.toList valueMap - , symtabP = HashMap.fromList $ Map.toList predMap - } - where - go (Number n) = Left $ Val Nothing n - go (Boolean b) = Right $ PredVal Nothing b - -functions :: Map.Map String (Expr Double, Function) -functions = - Map.fromList - [ ("compute_qualifies", (personQualifies, personQualifiesFunction)) - ] - -personQualifies :: Expr Double -personQualifies = - "qualifies" - @|= MathPred - ( (getvar "walks") |&& ((getvar "drinks") ||| (getvar "eats")) - ) - -personQualifiesFunction :: Function -personQualifiesFunction = - Function - "compute_qualifies" - [__i|Determines if a person qualifies for the purposes of the rule. - The input object describes the person's properties in the primary parameters: walks, eats, drinks. - Secondary parameters can be given which are sufficient to determine some of the primary parameters. - A person drinks whether or not they consume an alcoholic or a non-alcoholic beverage, in part or in whole; - those specific details don't really matter. - The output of the function can be either a request for required information; - a restatement of the user input requesting confirmation prior to function calling; - or a Boolean answer with optional explanation summary. - |] - $ Parameters - $ Properties - $ Map.fromList - [ ("walks", Parameter "string" ["true", "false", "unknown"] "Did the person walk?") - , ("eats", Parameter "string" ["true", "false", "unknown"] "Did the person eat?") - , ("drinks", Parameter "string" ["true", "false", "unknown"] "Did the person drink?") - , ("beverage type", Parameter "string" ["alcoholic", "non-alcoholic", "unknown"] "Did the person drink an alcoholic beverage?") - , ("in whole", Parameter "string" ["true", "false", "unknown"] "Did the person drink all of the beverage?") - ] +app :: Application +app = serve (Proxy @ApiWithSwagger) appWithSwagger diff --git a/lib/haskell/explainable/app/Schema.hs b/lib/haskell/explainable/app/Schema.hs new file mode 100644 index 000000000..f5e096ea7 --- /dev/null +++ b/lib/haskell/explainable/app/Schema.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Schema ( + serverOpenApi, + + -- * Tests + runJsonTests, +) where + +-- +import Control.Lens hiding ((.=)) +import Data.Aeson ((.=)) +import Data.Aeson qualified as Aeson +import Data.Map (Map) +import Data.OpenApi +import Data.Proxy +import Data.Text qualified as Text +import Servant.OpenApi +import Server hiding (description, name) +import Test.Hspec (hspec) +import Test.QuickCheck (Arbitrary (..), oneof) +import Test.QuickCheck.Gen qualified as Q +import Test.QuickCheck.Instances () + +serverOpenApi :: OpenApi +serverOpenApi = + toOpenApi (Proxy :: Proxy Api) + & info . title .~ "MathLang Function API" + & info . version .~ "1.0" + & info . description ?~ "API for invoking MathLang functions" + +-- ---------------------------------------------------------------------------- +-- Document and describe the Json schema using the OpenAPI standard +-- ---------------------------------------------------------------------------- + +instance ToSchema SimpleFunction where + declareNamedSchema _ = do + textRef <- declareSchemaRef (Proxy @Text.Text) + pure $ + NamedSchema (Just "Function") $ + mempty + & title ?~ "Function" + & type_ ?~ OpenApiObject + & properties + .~ [ ("type", textRef) + , + ( "function" + , Inline $ + mempty + & properties + .~ [ ("name", textRef) + , ("description", textRef) + ] + ) + ] + +-- This is correct, since we don't overwrite the +-- 'ToJSON SimpleResponse' instance yet. +instance ToSchema SimpleResponse + +-- This is correct, since we don't overwrite the +-- 'ToJSON ResponseWithReason' instance yet. +instance ToSchema ResponseWithReason + +-- This is correct, since we don't overwrite the +-- 'ToJSON MathLangException' instance yet. +instance ToSchema MathLangException + +-- This is correct, since we don't overwrite the +-- 'ToJSON Reasoning' instance yet. +instance ToSchema Reasoning + +-- This is correct, since we don't overwrite the +-- 'ToJSON ReasoningTree' instance yet. +instance ToSchema ReasoningTree + +instance ToSchema Function where + declareNamedSchema _ = do + textRef <- declareSchemaRef (Proxy @Text.Text) + parametersRef <- declareSchemaRef (Proxy @Parameters) + pure $ + NamedSchema (Just "Function") $ + mempty + & title ?~ "Function" + & type_ ?~ OpenApiObject + & properties + .~ [ ("type", textRef) + , + ( "function" + , Inline $ + mempty + & properties + .~ [ ("name", textRef) + , ("description", textRef) + , + ( "parameters" + , Inline $ + mempty + & properties + .~ [ ("type", textRef) + , ("properties", parametersRef) + ] + ) + ] + ) + ] + +instance ToSchema Parameters where + declareNamedSchema _ = do + parameterSchema <- declareSchemaRef (Proxy @Parameter) + mapSchema <- declareNamedSchema (Proxy @(Map String Parameter)) + pure $ + mapSchema + & name ?~ "FunctionParameters" + & schema . properties + .~ [ ("prop", parameterSchema) + ] + +instance ToSchema Parameter where + declareNamedSchema _ = do + textSchema <- declareSchemaRef (Proxy @Text.Text) + textListSchema <- declareSchemaRef (Proxy @[Text.Text]) + pure $ + NamedSchema (Just "FunctionParameter") $ + mempty + & type_ ?~ OpenApiObject + & title ?~ "Parameter" + & properties + .~ [ ("enum", textListSchema) + , ("description", textSchema) + , ("type", textSchema) + ] + & example + ?~ Aeson.object + [ "enum" .= (["true", "false", "unknown"] :: Aeson.Array) + , "description" .= Aeson.String "Can a person walk?" + , "type" .= Aeson.String "string" + ] + +-- ---------------------------------------------------------------------------- +-- Arbitrary instances that allow us to verify that the JSON +-- instances and OpenAPI documentation agree on the schema. +-- ---------------------------------------------------------------------------- + +instance Arbitrary Reasoning where + arbitrary = Reasoning <$> arbitrary + +-- | The code for this instance is taken from 'Arbitrary1 containers-Data.Tree.Tree'. +-- See https://hackage.haskell.org/package/QuickCheck-2.15.0.1/docs/src/Test.QuickCheck.Arbitrary.html#line-901 +instance Arbitrary ReasoningTree where + arbitrary = Q.sized $ \n -> do + k <- Q.chooseInt (0, n) + go k + where + go n = do + -- n is the size of the trees. + reasoningTrace <- arbitrary + reasoningExample <- arbitrary + pars <- arbPartition (n - 1) -- can go negative! + forest <- mapM go pars + return $ + ReasoningTree + { reasoningNodeExampleCode = reasoningExample + , reasoningNodeExplanation = reasoningTrace + , reasoningNodeChildren = forest + } + + arbPartition :: Int -> Q.Gen [Int] + arbPartition k = case compare k 1 of + LT -> pure [] + EQ -> pure [1] + GT -> do + first <- Q.chooseInt (1, k) + rest <- arbPartition $ k - first + Q.shuffle (first : rest) + +instance Arbitrary ResponseWithReason where + arbitrary = ResponseWithReason <$> arbitrary <*> arbitrary + +instance Arbitrary MathLangException where + arbitrary = MathLangException <$> arbitrary + +instance Arbitrary SimpleResponse where + arbitrary = + oneof + [ Server.SimpleResponse <$> arbitrary + , Server.SimpleError <$> arbitrary + ] + +instance Arbitrary Parameters where + arbitrary = Server.Parameters <$> arbitrary + +instance Arbitrary Parameter where + arbitrary = Server.Parameter <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Function where + arbitrary = Server.Function <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary SimpleFunction where + arbitrary = Server.SimpleFunction <$> arbitrary <*> arbitrary + +runJsonTests :: IO () +runJsonTests = hspec (validateEveryToJSON $ Proxy @Api) diff --git a/lib/haskell/explainable/app/Server.hs b/lib/haskell/explainable/app/Server.hs new file mode 100644 index 000000000..c2cf30e3c --- /dev/null +++ b/lib/haskell/explainable/app/Server.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module Server ( + -- * REST API + Api, + FunctionApi, + FunctionApi' (..), + SingleFunctionApi, + SingleFunctionApi' (..), + FunctionCrud, + FunctionCrud' (..), + handler, + + -- * API json types + Parameters (..), + Parameter (..), + Function (..), + SimpleFunction (..), + SimpleResponse (..), + Reasoning (..), + ReasoningTree (..), + ResponseWithReason (..), + MathLangException (..), +) where + +import Control.Monad (foldM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Except +import Data.Aeson (FromJSON, ToJSON, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.HashMap.Strict qualified as HashMap +import Data.Map qualified as Map +import Data.Maybe qualified as Maybe +import Data.String.Interpolate (__i) +import Data.Text qualified as Text +import Data.Text.Read qualified as TextReader +import Data.Tree qualified as Tree +import GHC.Generics +import Servant +import System.Timeout (timeout) + +import Explainable (XP) +import Explainable.MathLang + +-- ---------------------------------------------------------------------------- +-- Servant API +-- ---------------------------------------------------------------------------- + +type Api = NamedRoutes FunctionApi' +type FunctionApi = NamedRoutes FunctionApi' + +-- | API that can be invoked by a custom gpt. +-- +-- See https://openai.com/index/introducing-gpts/ +data FunctionApi' mode = FunctionApi + { functionRoutes :: mode :- "functions" :> FunctionCrud + } + deriving (Generic) + +type FunctionCrud = NamedRoutes FunctionCrud' +-- | API for interacting with the 'function' resource. +-- +data FunctionCrud' mode = FunctionCrud + { batchEntities :: + mode + :- Summary "Shortened descriptions of all available functions and their parameters" + :> Get '[JSON] [SimpleFunction] + , singleEntity :: mode :- Capture "name" String :> SingleFunctionApi + , computeQualifiesFunc :: + mode + :- "compute_qualifies" + :> QueryParam "drinks" Text.Text + :> QueryParam "eats" Text.Text + :> QueryParam "walks" Text.Text + :> Summary "Compute whether a person qualifies based on their properties" + :> Post '[JSON] SimpleResponse + -- ^ Run the 'compute_qualifies' function with the given parameters. + -- + -- Due to some issues, it seems like it is impossible (or very difficult), + -- to make custom gpts invoke REST endpoints with JSON bodies... So, for + -- now we simply send all parameters via Query Parameters. + -- Until the next servant release, we have to explicitly name all + -- query parameters. See + -- https://github.com/haskell-servant/servant/pull/1604 for the PR that we + -- are interested in. + } + deriving (Generic) + +type SingleFunctionApi = NamedRoutes SingleFunctionApi' +data SingleFunctionApi' mode = SingleFunctionApi + { getFunction :: + mode + :- Summary "Get a detailed description of the function and its parameters" + :> Get '[JSON] Function + } + deriving (Generic) + +data SimpleResponse + = SimpleResponse ResponseWithReason + | SimpleError MathLangException + deriving (Show, Read, Ord, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +{- | A MathLangException is some form of panic thrown by 'MathLang'. +The execution of a function had to be interrupted for /some/ reason. +Such an exception is unrecoverable. +The error message may contain hints of what might have gone wrong. +-} +newtype MathLangException = MathLangException + { getMathLangException :: Text.Text + -- ^ Error message of a fatal math lang execution exception. + } + deriving (Show, Read, Ord, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +data ResponseWithReason = ResponseWithReason + { responseValue :: Double + , responseReasoning :: Reasoning + } + deriving (Show, Read, Ord, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +data SimpleFunction = SimpleFunction + { simpleName :: Text.Text + , simpleDescription :: Text.Text + } + deriving (Show, Read, Ord, Eq, Generic) + +data Function = Function + { name :: Text.Text + , description :: Text.Text + , parameters :: Parameters + } + deriving (Show, Read, Ord, Eq, Generic) + +newtype Parameters = Parameters + { getParameters :: Map.Map String Parameter + } + deriving (Show, Read, Ord, Eq, Generic) + +-- | Wrap our reasoning into a top-level field. +newtype Reasoning = Reasoning + { getReasoning :: ReasoningTree + } + deriving (Show, Read, Ord, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +-- | Basically a rose tree, but serialisable to json and specialised to our purposes. +data ReasoningTree = ReasoningTree + { reasoningNodeExampleCode :: [Text.Text] + , reasoningNodeExplanation :: [Text.Text] + , reasoningNodeChildren :: [ReasoningTree] + } + deriving (Show, Read, Ord, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) + +-- ---------------------------------------------------------------------------- +-- Web Service Handlers +-- ---------------------------------------------------------------------------- + +handler :: Server Api +handler = + FunctionApi + { functionRoutes = + FunctionCrud + { batchEntities = handlerFunctions + , singleEntity = \name -> + SingleFunctionApi + { getFunction = + handlerParameters name + } + , computeQualifiesFunc = + computeQualifiesHandler + } + } + +handlerFunctions :: Handler [SimpleFunction] +handlerFunctions = do + pure $ fmap (toSimpleFunction . snd) $ Map.elems functions + where + toSimpleFunction s = + SimpleFunction + { simpleName = name s + , simpleDescription = description s + } + +computeQualifiesHandler :: Maybe Text.Text -> Maybe Text.Text -> Maybe Text.Text -> Handler SimpleResponse +computeQualifiesHandler drinks eats walks = do + let + params = + [("drinks", drinks), ("walks", walks), ("eats", eats)] + case Map.lookup "compute_qualifies" functions of + Nothing -> throwError err404 + Just (function, _) -> + case runExcept $ fromParams $ Maybe.mapMaybe (\(k, v) -> (k,) <$> v) params of + Left err -> + throwError + err400 + { errReasonPhrase = Text.unpack err + } + Right s -> do + response <- timeoutAction $ runFunction s function + pure $ SimpleResponse response + +handlerParameters :: String -> Handler Function +handlerParameters name = case Map.lookup name functions of + Nothing -> throwError err404 + Just (_, scenario) -> pure scenario + +timeoutAction :: IO b -> Handler b +timeoutAction act = + liftIO (timeout (seconds 5) act) >>= \case + Nothing -> throwError err505 + Just r -> pure r + where + seconds n = 1_000_000 * n + +-- ---------------------------------------------------------------------------- +-- Json encoders and decoders that are not derived. +-- We often need custom instances, as we want to be more lenient in what we accept +-- than what aeson does by default. Further, we try to provide a specific json schema. +-- +-- ---------------------------------------------------------------------------- + +instance ToJSON SimpleFunction where + toJSON (SimpleFunction n desc) = + Aeson.object + [ "type" .= Aeson.String "function" + , "function" + .= Aeson.object + [ "name" .= Aeson.String n + , "description" .= Aeson.String desc + ] + ] + +instance FromJSON SimpleFunction where + parseJSON = Aeson.withObject "Function" $ \o -> do + "function" :: Text.Text <- o .: "type" + props <- o .: "function" + (n, d) <- + Aeson.withObject + "function body" + ( \p -> do + (,) + <$> p .: "name" + <*> p .: "description" + ) + props + pure $ SimpleFunction n d + +instance ToJSON Function where + toJSON (Function n desc params) = + Aeson.object + [ "type" .= Aeson.String "function" + , "function" + .= Aeson.object + [ "name" .= Aeson.String n + , "description" .= Aeson.String desc + , "parameters" .= params + ] + ] + +instance FromJSON Function where + parseJSON = Aeson.withObject "Function" $ \o -> do + "function" :: Text.Text <- o .: "type" + props <- o .: "function" + (n, d, p) <- + Aeson.withObject + "function body" + ( \p -> do + (,,) + <$> p .: "name" + <*> p .: "description" + <*> p .: "parameters" + ) + props + pure $ Function n d p + +instance ToJSON Parameters where + toJSON (Parameters props) = + Aeson.object + [ "type" .= Aeson.String "object" + , "properties" .= props + ] + +instance FromJSON Parameters where + parseJSON = Aeson.withObject "Parameters" $ \o -> do + _ :: Text.Text <- o .: "type" + props <- o .: "properties" + pure $ Parameters props + +data Parameter = Parameter + { parameterType :: String + , parameterEnum :: [String] + , parameterDescription :: String + } + deriving (Show, Read, Ord, Eq, Generic) + +instance ToJSON Parameter where + toJSON (Parameter ty enum desc) = + Aeson.object + [ "type" .= ty + , "enum" .= enum + , "description" .= desc + ] + +instance FromJSON Parameter where + parseJSON = Aeson.withObject "Parameter" $ \p -> + Parameter + <$> p .: "type" + <*> p .: "enum" + <*> p .: "description" + +-- ---------------------------------------------------------------------------- +-- Helpers +-- ---------------------------------------------------------------------------- + +runFunction :: (MonadIO m) => MyState -> Expr Double -> m ResponseWithReason +runFunction s scenario = do + (res, xp, _, _) <- liftIO $ xplainF () s scenario + pure $ ResponseWithReason res (Reasoning $ reasoningFromXp xp) + +fromParams :: [(Text.Text, Text.Text)] -> Except Text.Text MyState +fromParams attrs = do + let + explainableState = emptyState + + parseTextToVariables key val state + | Right (d, "") <- TextReader.double val = + pure $ + state + { symtabF = HashMap.insert (Text.unpack key) (Val Nothing d) (symtabF state) + } + | Just b <- parseAsBool val = + pure $ + state + { symtabP = HashMap.insert (Text.unpack key) (PredVal Nothing b) (symtabP state) + } + | otherwise = throwError $ "Unexpected value \"" <> val <> "\" for argument " <> key + foldM (\s (k, v) -> parseTextToVariables k v s) explainableState attrs + where + parseAsBool t = case Text.toLower t of + "true" -> Just True + "false" -> Just False + _ -> Nothing + +{- | Translate a Tree of explanations into a reasoning tree that can be sent over +the wire. +For now, this is essentially just a 1:1 translation, but might prune the tree in the future. +-} +reasoningFromXp :: XP -> ReasoningTree +reasoningFromXp (Tree.Node (xpExampleCode, xpJustification) children) = + ReasoningTree + (fmap Text.pack xpExampleCode) + (fmap Text.pack xpJustification) + (fmap reasoningFromXp children) + +-- ---------------------------------------------------------------------------- +-- Example Rules +-- ---------------------------------------------------------------------------- + +-- | Example functions for the purpose of showcasing the REST API. +functions :: Map.Map String (Expr Double, Function) +functions = + Map.fromList + [ ("compute_qualifies", (personQualifies, personQualifiesFunction)) + ] + +-- | Example function which computes whether a person qualifies for *something*. +personQualifies :: Expr Double +personQualifies = + "qualifies" + @|= MathPred + ( getvar "walks" |&& (getvar "drinks" ||| getvar "eats") + ) + +{- | Metadata about the function that the user might want to know. +Further, an LLM could use this info to ask specific questions to the user. +-} +personQualifiesFunction :: Function +personQualifiesFunction = + Function + "compute_qualifies" + [__i|Determines if a person qualifies for the purposes of the rule. + The input object describes the person's properties in the primary parameters: walks, eats, drinks. + Secondary parameters can be given which are sufficient to determine some of the primary parameters. + A person drinks whether or not they consume an alcoholic or a non-alcoholic beverage, in part or in whole; + those specific details don't really matter. + The output of the function can be either a request for required information; + a restatement of the user input requesting confirmation prior to function calling; + or a Boolean answer with optional explanation summary. + |] + $ Parameters + $ Map.fromList + [ ("walks", Parameter "string" ["true", "false"] "Did the person walk?") + , ("eats", Parameter "string" ["true", "false"] "Did the person eat?") + , ("drinks", Parameter "string" ["true", "false"] "Did the person drink?") + , ("beverage type", Parameter "string" ["alcoholic", "non-alcoholic"] "Did the person drink an alcoholic beverage?") + , ("in whole", Parameter "string" ["true", "false"] "Did the person drink all of the beverage?") + ] diff --git a/lib/haskell/explainable/explainable.cabal b/lib/haskell/explainable/explainable.cabal index 501431482..c1d64b555 100644 --- a/lib/haskell/explainable/explainable.cabal +++ b/lib/haskell/explainable/explainable.cabal @@ -60,14 +60,18 @@ executable explainable-exe main-is: Main.hs other-modules: Options + Schema + Server Paths_explainable hs-source-dirs: app ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson + QuickCheck + , aeson , base >=4.7 && <5 , boxes + , bytestring , containers , directory , effectful @@ -75,18 +79,24 @@ executable explainable-exe , fgl , filepath , graphviz + , hspec + , lens , megaparsec , mtl , numeric-extras + , openapi3 , optparse-applicative , parsec , parser-combinators , pcre-heavy , prettyprinter , prettyprinter-interp + , quickcheck-instances , scientific , servant + , servant-openapi3 , servant-server + , servant-swagger-ui , string-interpolate , text , transformers diff --git a/lib/haskell/explainable/package.yaml b/lib/haskell/explainable/package.yaml index d79089661..ebd3f1b1d 100644 --- a/lib/haskell/explainable/package.yaml +++ b/lib/haskell/explainable/package.yaml @@ -59,9 +59,9 @@ library: executables: explainable-exe: main: Main.hs - other-modules: - - Options - - Paths_explainable + # other-modules: + # - Options + # - Paths_explainable source-dirs: app ghc-options: - -Wall @@ -69,16 +69,25 @@ executables: - -rtsopts - -with-rtsopts=-N dependencies: + - bytestring - explainable - servant - servant-server + - servant-openapi3 + - servant-swagger-ui + - openapi3 - warp - wai - wai-logger - directory - filepath + - lens - optparse-applicative - scientific + - QuickCheck + - quickcheck-instances + # TODO: if this project advances, the server should be its own library + - hspec tests: explainable-test: