Skip to content

Commit

Permalink
Implement OIA batch API
Browse files Browse the repository at this point in the history
  • Loading branch information
@fendor
fendor committed Sep 23, 2024
1 parent c3786d0 commit 110c232
Show file tree
Hide file tree
Showing 9 changed files with 264 additions and 137 deletions.
1 change: 1 addition & 0 deletions lib/haskell/web-service/package.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ dependencies:
- aeson-combinators
- bytestring
- containers
- chronos
- extra
- unordered-containers
- transformers
Expand Down
7 changes: 5 additions & 2 deletions lib/haskell/web-service/src/Backend/Api.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ import Control.Monad.Trans.Except (ExceptT)
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson
import Data.Map.Strict (Map)
import Data.Scientific qualified as Scientific
import Data.Set (Set)
import Data.Text (Text)
Expand Down Expand Up @@ -52,17 +53,19 @@ instance FromJSON FnLiteral where
data Evaluator = Evaluator
{ runEvaluatorForFunction ::
[(Text, Maybe FnLiteral)] ->
Maybe (Set Text) ->
ExceptT EvaluatorError IO ResponseWithReason
}

data FunctionDeclaration = FunctionDeclaration
{ name :: !Text
, description :: !Text
, parameters :: !(Set Text)
, parametersLongNames :: !(Set Text)
, parametersMapping :: !(Map Text Text)
}

data ResponseWithReason = ResponseWithReason
{ responseValue :: FnLiteral
{ responseValue :: [(Text, FnLiteral)]
, responseReasoning :: Reasoning
}
deriving (Show, Read, Ord, Eq, Generic)
Expand Down
10 changes: 5 additions & 5 deletions lib/haskell/web-service/src/Backend/Explainable.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -21,19 +21,19 @@ import Explainable.MathLang
genericMathLangEvaluator :: FunctionDeclaration -> Expr Double -> Evaluator
genericMathLangEvaluator fnDecl expr =
Evaluator
{ runEvaluatorForFunction = functionHandler fnDecl expr
{ runEvaluatorForFunction = \args _ -> functionHandler fnDecl expr args
}

functionHandler :: (MonadIO m) => FunctionDeclaration -> Expr Double -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m ResponseWithReason
functionHandler decl impl args
| length decl.parameters /= length args =
| length decl.parametersLongNames /= length args =
throwError $
RequiredParameterMissing $
ParameterMismatch
{ expectedParameters = length decl.parameters
{ expectedParameters = length decl.parametersLongNames
, actualParameters = length args
}
| unknowns@(_ : _) <- filter (\(k, _) -> Set.notMember k decl.parameters) args =
| unknowns@(_ : _) <- filter (\(k, _) -> Set.notMember k decl.parametersLongNames) args =
throwError $
UnknownArguments $
fmap fst unknowns
Expand All @@ -48,7 +48,7 @@ runExplainableInterpreter s scenario = do
Left (e :: IOError) -> do
throwError $ InterpreterError $ Text.pack $ show e
Right (res, xp, _, _) -> do
pure $ ResponseWithReason (FnLitDouble res) (Reasoning $ reasoningFromXp xp)
pure $ ResponseWithReason [("output", FnLitDouble res)] (Reasoning $ reasoningFromXp xp)

transformParameters :: (MonadIO m) => [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m MyState
transformParameters attrs = do
Expand Down
134 changes: 85 additions & 49 deletions lib/haskell/web-service/src/Backend/Simala.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,12 +5,25 @@

module Backend.Simala (simalaEvaluator) where

import Backend.Api
import Control.Monad (foldM)
import Backend.Api (
Evaluator (..),
EvaluatorError (InterpreterError, UnknownArguments),
FnLiteral (..),
FunctionDeclaration (parametersLongNames, parametersMapping),
ReasonNode (
ReasonNode,
reasoningNodeExampleCode,
reasoningNodeExplanation
),
Reasoning (Reasoning),
ReasoningTree (..),
ResponseWithReason (..),
)
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
Expand All @@ -19,15 +32,15 @@ import Simala.Eval.Type qualified as Simala
import Simala.Expr.Evaluator qualified as Simala
import Simala.Expr.Parser qualified as Simala
import Simala.Expr.Render qualified as Simala
import Simala.Expr.Type qualified as Simala
import Simala.Expr.Type as Simala

simalaEvaluator ::
(Monad m) =>
FunctionDeclaration ->
Text ->
ExceptT EvaluatorError m Evaluator
simalaEvaluator fnDecl fnImpl =
case Simala.parseExpr "" fnImpl of
case Simala.parseDecls "" fnImpl of
Left err -> throwError $ InterpreterError $ "Failed to parse Simala program: " <> Text.pack err
Right expr ->
pure $
Expand All @@ -37,38 +50,40 @@ simalaEvaluator fnDecl fnImpl =

functionHandler ::
FunctionDeclaration ->
Simala.Expr ->
[Decl] ->
[(Text, Maybe FnLiteral)] ->
Maybe (Set Text) ->
ExceptT EvaluatorError IO ResponseWithReason
functionHandler decl impl args
| length decl.parameters /= length args =
throwError $
RequiredParameterMissing $
ParameterMismatch
{ expectedParameters = length decl.parameters
, actualParameters = length args
}
| unknowns@(_ : _) <- filter (\(k, _) -> Set.notMember k decl.parameters) args =
throwError $
UnknownArguments $
fmap fst unknowns
| otherwise = do
evaluatorState <- transformParameters args
evaluator evaluatorState impl
functionHandler decl impl args outputs = do
input <- transformParameters decl args
evaluator input outputs impl

evaluator :: (MonadIO m) => Simala.Env -> Simala.Expr -> ExceptT EvaluatorError m ResponseWithReason
evaluator env expr = do
evaluator ::
(MonadIO m) =>
Row Expr ->
Maybe (Set Text) ->
[Decl] ->
ExceptT EvaluatorError m ResponseWithReason
evaluator inputs outputVars decls = do
let
(result, evalTrace) = Simala.runEval (Simala.withEnv env (Simala.eval expr))
evalCall = Eval $ App (Var "rules") [Record inputs]
declsWithInput = decls <> [evalCall]
(result, evalTrace) = Simala.runEval' (Simala.evalDecls declsWithInput)
case result of
Left err -> throwError $ InterpreterError $ "Failed to evaluate expression: " <> Simala.render err
Right val -> do
r <- simalaValToFnLiteral val
pure $
ResponseWithReason
{ responseValue = r
, responseReasoning = Reasoning $ reasoningFromEvalTrace evalTrace
}
Right () -> do
case evalTrace of
[(Right (VRecord outputs), trace)] -> do
outputsFn' <- traverse (\(k, v) -> fmap (k,) (simalaValToFnLiteral v)) outputs
-- Only keep the fields in the output that were actually requested.
-- If nothing was explicitly requested, we keep all outputs.
let outputsFn = maybe outputsFn' (\keys -> filter (\(k, _) -> Set.member k keys) outputsFn') outputVars
pure $
ResponseWithReason
{ responseValue = outputsFn
, responseReasoning = Reasoning $ reasoningFromEvalTrace trace
}
e -> throwError $ InterpreterError $ "Unexpected output format: " <> Text.pack (show e)

reasoningFromEvalTrace :: Simala.EvalTrace -> ReasoningTree
reasoningFromEvalTrace = go
Expand All @@ -95,31 +110,52 @@ reasoningFromEvalTrace = go
}
, treeChildren = map go subs
}
renderResult :: Maybe Simala.Name -> Either Simala.EvalError Simala.Val -> Text
renderResult (Just n) (Right x) = (Simala.render n <> " = " <> Simala.render x)
renderResult (Just n) (Left x) = (Simala.render n <> " aborted with " <> Simala.render x)
renderResult Nothing (Right x) = (Simala.render x)
renderResult Nothing (Left x) = (Simala.render x)
renderResult :: Maybe Name -> Either Simala.EvalError Val -> Text
renderResult (Just n) (Right x) = Simala.render n <> " = " <> Simala.render x
renderResult (Just n) (Left x) = Simala.render n <> " aborted with " <> Simala.render x
renderResult Nothing (Right x) = Simala.render x
renderResult Nothing (Left x) = Simala.render x

transformParameters :: (MonadIO m) => FunctionDeclaration -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m (Row Expr)
transformParameters decl attrs = do
let
splitParameters key mValue = do
-- We support long and short names for the same parameter name.
-- This makes us compatible with OIA.
keyName <- case key `Set.member` decl.parametersLongNames of
False -> case key `Map.lookup` decl.parametersMapping of
Nothing -> throwError $ UnknownArguments [key]
Just longName -> pure longName
True -> pure key
val <- case mValue of
Nothing ->
-- null is resolved to 'uncertain per OIA convention
pure uncertain
Just arg -> do
fnLiteralToSimalaVar arg

pure (keyName, val)

transformParameters :: (MonadIO m) => [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m Simala.Env
transformParameters attrs = do
env <- traverse (\(k, v) -> splitParameters k v) attrs
-- Unknown parameters are added to the input as 'uncertain
let
initialState = Map.empty
parametersNotGiven = Set.toList $ Set.difference decl.parametersLongNames (Set.fromList $ fmap fst env)

splitParameters _ Nothing _ = throwError $ CannotHandleUnknownVars
splitParameters key (Just arg) env = do
simalaVal <- fnLiteralToSimalaVar arg
pure $ Map.insert key simalaVal env
foldM (\s (k, v) -> splitParameters k v s) initialState attrs
let
allInputs =
env <> fmap (,uncertain) parametersNotGiven
pure allInputs
where
uncertain = Atom "uncertain"

fnLiteralToSimalaVar :: (MonadIO m) => FnLiteral -> ExceptT EvaluatorError m Simala.Val
fnLiteralToSimalaVar :: (MonadIO m) => FnLiteral -> ExceptT EvaluatorError m Expr
fnLiteralToSimalaVar = \case
FnLitInt integer -> pure $ Simala.VInt $ fromIntegral integer
FnLitDouble _ -> throwError undefined
FnLitBool b -> pure $ Simala.VBool b
FnLitString atom -> pure $ Simala.VAtom atom
FnLitInt integer -> pure $ Lit $ IntLit $ fromIntegral integer
FnLitDouble d -> pure $ Lit $ FracLit d
FnLitBool b -> pure $ Lit $ BoolLit b
FnLitString atom -> pure $ Atom atom

simalaValToFnLiteral :: (MonadIO m) => Simala.Val -> ExceptT EvaluatorError m FnLiteral
simalaValToFnLiteral :: (MonadIO m) => Val -> ExceptT EvaluatorError m FnLiteral
simalaValToFnLiteral = \case
Simala.VInt integer -> pure $ FnLitInt $ fromIntegral integer
Simala.VBool b -> pure $ FnLitBool b
Expand Down
105 changes: 50 additions & 55 deletions lib/haskell/web-service/src/Examples.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -50,9 +50,9 @@ personQualifiesFunction = do
, parameters =
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?")
[ ("walks", Parameter "string" Nothing ["true", "false"] "Did the person walk?")
, ("eats", Parameter "string" Nothing ["true", "false"] "Did the person eat?")
, ("drinks", Parameter "string" Nothing ["true", "false"] "Did the person drink?")
]
, supportedEvalBackend = [GenericMathLang, Simala]
}
Expand Down Expand Up @@ -91,16 +91,16 @@ rodentsAndVerminFunction = do
, parameters =
Parameters $
Map.fromList
[ ("Loss or Damage.caused by insects", Parameter "string" ["true", "false"] "Was the damage caused by insects?")
, ("Loss or Damage.caused by birds", Parameter "string" ["true", "false"] "Was the damage caused by birds?")
, ("Loss or Damage.caused by vermin", Parameter "string" ["true", "false"] "Was the damage caused by vermin?")
, ("Loss or Damage.caused by rodents", Parameter "string" ["true", "false"] "Was the damage caused by rodents?")
, ("Loss or Damage.to Contents", Parameter "string" ["true", "false"] "Is the damage to your contents?")
, ("Loss or Damage.ensuing covered loss", Parameter "string" ["true", "false"] "Is the damage ensuing covered loss")
, ("any other exclusion applies", Parameter "string" ["true", "false"] "Are any other exclusions besides mentioned ones?")
, ("a household appliance", Parameter "string" ["true", "false"] "Did water escape from a household appliance due to an animal?")
, ("a swimming pool", Parameter "string" ["true", "false"] "Did water escape from a swimming pool due to an animal?")
, ("a plumbing, heating, or air conditioning system", Parameter "string" ["true", "false"] "Did water escape from a plumbing, heating or conditioning system due to an animal?")
[ ("Loss or Damage.caused by insects", Parameter "string" Nothing ["true", "false"] "Was the damage caused by insects?")
, ("Loss or Damage.caused by birds", Parameter "string" Nothing ["true", "false"] "Was the damage caused by birds?")
, ("Loss or Damage.caused by vermin", Parameter "string" Nothing ["true", "false"] "Was the damage caused by vermin?")
, ("Loss or Damage.caused by rodents", Parameter "string" Nothing ["true", "false"] "Was the damage caused by rodents?")
, ("Loss or Damage.to Contents", Parameter "string" Nothing ["true", "false"] "Is the damage to your contents?")
, ("Loss or Damage.ensuing covered loss", Parameter "string" Nothing ["true", "false"] "Is the damage ensuing covered loss")
, ("any other exclusion applies", Parameter "string" Nothing ["true", "false"] "Are any other exclusions besides mentioned ones?")
, ("a household appliance", Parameter "string" Nothing ["true", "false"] "Did water escape from a household appliance due to an animal?")
, ("a swimming pool", Parameter "string" Nothing ["true", "false"] "Did water escape from a swimming pool due to an animal?")
, ("a plumbing, heating, or air conditioning system", Parameter "string" Nothing ["true", "false"] "Did water escape from a plumbing, heating or conditioning system due to an animal?")
]
, supportedEvalBackend = [GenericMathLang, Simala]
}
Expand All @@ -124,52 +124,47 @@ rodentsAndVerminFunction = do
computeQualifiesSimala :: Text
computeQualifiesSimala =
[i|
let
computeQualifies = fun () => walks && (drinks || eats)
in
computeQualifies ()
rules = fun(i) =>
{ qualifies = i.walks && (i.drinks || i.eats)
}
|]

rodentsAndVerminSimala :: Text
rodentsAndVerminSimala =
[i|
let
notCoveredIf = fun (b) => if b then true else false
in
let
lossOrDamagedByAnimals =
`Loss or Damage.caused by rodents`
|| `Loss or Damage.caused by insects`
|| `Loss or Damage.caused by vermin`
|| `Loss or Damage.caused by birds`
in
let
damageToContentsAndCausedByBirds =
`Loss or Damage.to Contents`
&& `Loss or Damage.caused by birds`
in
let
ensuingCoveredLoss = `Loss or Damage.ensuing covered loss`
in
let
exclusionsApply =
`any other exclusion applies`
|| `a household appliance`
|| `a swimming pool`
|| `a plumbing, heating, or air conditioning system`
in
let
rodentsAndVermin = fun () => notCoveredIf
( lossOrDamagedByAnimals
&& not
( damageToContentsAndCausedByBirds
|| ( ensuingCoveredLoss
&& not ( exclusionsApply )
)
)
)
in
rodentsAndVermin ()
rules = fun(i) =>
let
notCoveredIf = fun (b) => if b then true else false ;

lossOrDamagedByAnimals =
i.`Loss or Damage.caused by rodents`
|| i.`Loss or Damage.caused by insects`
|| i.`Loss or Damage.caused by vermin`
|| i.`Loss or Damage.caused by birds` ;

damageToContentsAndCausedByBirds =
i.`Loss or Damage.to Contents`
&& i.`Loss or Damage.caused by birds` ;

ensuingCoveredLoss = i.`Loss or Damage.ensuing covered loss` ;

exclusionsApply =
i.`any other exclusion applies`
|| i.`a household appliance`
|| i.`a swimming pool`
|| i.`a plumbing, heating, or air conditioning system` ;

in
{ covered = notCoveredIf
( lossOrDamagedByAnimals
&& not
( damageToContentsAndCausedByBirds
|| ( ensuingCoveredLoss
&& not ( exclusionsApply )
)
)
)
}
|]

-- | Example function which computes whether a person qualifies for *something*.
Expand Down Expand Up @@ -251,5 +246,5 @@ rodentsAndVerminGml =

builtinProgram :: Except EvaluatorError a -> a
builtinProgram m = case runExcept m of
Left err -> error $ "Builtin failed to load" <> show err
Left err -> error $ "Builtin failed to load " <> show err
Right e -> e
Loading

0 comments on commit 110c232

Please sign in to comment.