Add FnUnknown and FnUncertain as first class values

lib/haskell/web-service/src/Backend/Api.hs

@@ -8,9 +8,9 @@ module Backend.Api (
 ) where
 
 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.Aeson as Aeson
+import Data.Aeson.KeyMap qualified as Aeson
+import Data.Aeson.Types as Aeson
 import Data.Map.Strict (Map)
 import Data.Scientific qualified as Scientific
 import Data.Set (Set)
@@ -28,33 +28,45 @@ data FnLiteral
   | FnLitDouble !Double
   | FnLitBool !Bool
   | FnLitString !Text
+  | FnUncertain
+  | FnUnknown
   deriving (Show, Read, Ord, Eq, Generic)
 
 instance ToJSON FnLiteral where
   toJSON = \case
-    FnLitInt val -> Aeson.String $ tshow val
-    FnLitDouble val -> Aeson.String $ tshow val
-    FnLitBool val -> Aeson.String $ tshow val
-    FnLitString val -> Aeson.String val
+    FnLitInt val -> String $ tshow val
+    FnLitDouble val -> String $ tshow val
+    FnLitBool val -> String $ tshow val
+    FnLitString val -> String val
+    FnUncertain -> Object $ Aeson.fromList []
+    FnUnknown -> Null
    where
     tshow :: forall a. (Show a) => a -> Text
     tshow = Text.pack . show
 
 instance FromJSON FnLiteral where
   parseJSON = \case
-    Aeson.String val -> pure $ parseTextAsFnLiteral val
-    Aeson.Bool val -> pure $ FnLitBool val
-    Aeson.Number val
+    String val -> pure $ parseTextAsFnLiteral val
+    Bool val -> pure $ FnLitBool val
+    Number val
       | Just (i :: Int) <- Scientific.toBoundedInteger val -> pure $ FnLitInt $ fromIntegral i
       | Right d <- Scientific.toBoundedRealFloat val -> pure $ FnLitDouble d
-      | otherwise -> Aeson.typeMismatch "Failed to parse number into bounded real or integer" (Aeson.Number val)
+      | otherwise -> Aeson.typeMismatch "Failed to parse number into bounded real or integer" (Number val)
+    Null -> pure FnUnknown
+    Object o
+      | [] <- Aeson.toList o -> pure FnUncertain
     obj -> Aeson.typeMismatch "Failed to parse FnLiteral" obj
 
-data Evaluator = Evaluator
-  { runEvaluatorForFunction ::
+data RunFunction = RunFunction
+  { runFunction ::
+      -- ^ Parameters to the function
       [(Text, Maybe FnLiteral)] ->
+      -- ^ Output filter, as the function may return a record of
+      -- outputs.
+      -- If this filter is 'Nothing', we do not filter anything.
       Maybe (Set Text) ->
       ExceptT EvaluatorError IO ResponseWithReason
+  -- ^ Run a function with parameters
   }
 
 data FunctionDeclaration = FunctionDeclaration
@@ -78,6 +90,17 @@ data Reasoning = Reasoning
   deriving (Show, Read, Ord, Eq, Generic)
   deriving anyclass (FromJSON, ToJSON)
 
+emptyTree :: Reasoning
+emptyTree = Reasoning
+  { getReasoning = ReasoningTree
+    { treeNode = ReasonNode
+        { reasoningNodeExampleCode = []
+        , reasoningNodeExplanation = []
+        }
+    , treeChildren = []
+    }
+  }
+
 -- | Basically a rose tree, but serialisable to json and specialised to our purposes.
 data ReasoningTree = ReasoningTree
   { treeNode :: ReasonNode
@@ -86,6 +109,7 @@ data ReasoningTree = ReasoningTree
   deriving stock (Show, Read, Ord, Eq, Generic)
   deriving anyclass (FromJSON, ToJSON)
 
+
 data ReasonNode = ReasonNode
   { reasoningNodeExampleCode :: [Text]
   , reasoningNodeExplanation :: [Text]

lib/haskell/web-service/src/Backend/Explainable.hs

@@ -18,10 +18,10 @@ import Data.Tree qualified as Tree
 import Explainable (XP)
 import Explainable.MathLang
 
-genericMathLangEvaluator :: FunctionDeclaration -> Expr Double -> Evaluator
+genericMathLangEvaluator :: FunctionDeclaration -> Expr Double -> RunFunction
 genericMathLangEvaluator fnDecl expr =
-  Evaluator
-    { runEvaluatorForFunction = \args _ -> functionHandler fnDecl expr args
+  RunFunction
+    { runFunction = \args _ -> functionHandler fnDecl expr args
     }
 
 functionHandler :: (MonadIO m) => FunctionDeclaration -> Expr Double -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m ResponseWithReason
@@ -77,6 +77,8 @@ transformParameters attrs = do
           state
             { symtabS = HashMap.insert (Text.unpack key) (Text.unpack t) (symtabS state)
             }
+      p ->
+        throwError $ InterpreterError $ "Gml can't handle parameter type: " <> Text.pack (show p)
   foldM (\s (k, v) -> splitParameters k v s) explainableState attrs
 
 -- | Translate a Tree of explanations into a reasoning tree that can be sent over

lib/haskell/web-service/src/Backend/Simala.hs

@@ -3,22 +3,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 
-module Backend.Simala (simalaEvaluator) where
-
-import Backend.Api (
-  Evaluator (..),
-  EvaluatorError (InterpreterError, UnknownArguments),
-  FnLiteral (..),
-  FunctionDeclaration (parametersLongNames, parametersMapping),
-  ReasonNode (
-    ReasonNode,
-    reasoningNodeExampleCode,
-    reasoningNodeExplanation
-  ),
-  Reasoning (Reasoning),
-  ReasoningTree (..),
-  ResponseWithReason (..),
- )
+module Backend.Simala (createSimalaFunction) where
+
+import Control.Applicative (asum)
 import Control.Monad.Error.Class
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
@@ -27,79 +14,102 @@ import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as Text
-import Data.Text.IO qualified as Text
+
+import Backend.Api
 import Simala.Eval.Monad qualified as Simala
 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 as Simala
-import qualified Data.List as List
-import Control.Applicative (asum)
-import qualified Data.Maybe as Maybe
 
-simalaEvaluator ::
+createSimalaFunction ::
   (Monad m) =>
   FunctionDeclaration ->
   Text ->
-  ExceptT EvaluatorError m Evaluator
-simalaEvaluator fnDecl fnImpl =
+  ExceptT EvaluatorError m RunFunction
+createSimalaFunction fnDecl fnImpl =
   case Simala.parseDecls "" fnImpl of
     Left err -> throwError $ InterpreterError $ "Failed to parse Simala program: " <> Text.pack err
     Right expr ->
       pure $
-        Evaluator
-          { runEvaluatorForFunction = functionHandler fnDecl expr
+        RunFunction
+          { runFunction = runSimalaFunction fnDecl expr
           }
 
-functionHandler ::
+runSimalaFunction ::
   FunctionDeclaration ->
   [Decl] ->
   [(Text, Maybe FnLiteral)] ->
   Maybe (Set Text) ->
   ExceptT EvaluatorError IO ResponseWithReason
-functionHandler decl impl args outputs = do
+runSimalaFunction decl impl args outputFilter = do
   input <- transformParameters decl args
-  evaluator input outputs impl
+  evalSimala input outputFilter impl
 
-evaluator ::
-  (MonadIO m) =>
+-- | Evaluate the simala program using the given parameters.
+--
+-- We assume each program defines a function named 'rules' which we think as the
+-- the main entry point of a program.
+-- We additionally allow a function named 'rules*' (e.g. 'rules_1234') to be the
+-- main entry point to simala.
+evalSimala ::
+  (Monad m) =>
+  -- | A record of inputs which are assumed to be validated and complete.
+  -- Complete means that each parameter specified in a 'FunctionDeclaration'
+  -- is included in this row.
   Row Expr ->
+  -- | Optional output variable filter. If 'Nothing', no filter is applied.
   Maybe (Set Text) ->
+  -- | The parsed program to evaluate.
   [Decl] ->
   ExceptT EvaluatorError m ResponseWithReason
-evaluator inputs outputVars decls = do
+evalSimala inputs outputFilter decls = do
   let
-    rulesName = asum $ fmap (\case
-        NonRec _ name _
-          | Text.isPrefixOf "rules" name -> Just name
-        Rec _ name _
-          | Text.isPrefixOf "rules" name -> Just name
-        _ -> Nothing) decls
-
-  case rulesName of
-    Nothing -> throwError $ InterpreterError $ "No \"rules\" function found"
-    Just ruleName -> do
+    isRulesName = Text.isPrefixOf "rules"
+
+    mMainRuleName =
+      asum $
+        fmap
+          ( \case
+              NonRec _ name _
+                | isRulesName name -> Just name
+              Rec _ name _
+                | isRulesName name -> Just name
+              _ -> Nothing
+          )
+          decls
+
+  case mMainRuleName of
+    Nothing -> throwError $ InterpreterError $ "No \"rules\" main function found"
+    Just mainRuleName -> do
       let
-        evalCall = Eval $ App (Var ruleName) [Record inputs]
+        -- To get anything evaluated, we programmatically add a so-called '#eval'
+        -- declaration.
+        -- In simala, this looks like '#eval rules({...})'.
+        -- We expect each program has exactly one such '#eval' declaration.
+        -- TODO: As we have parsed the program, we could reject a program if it contains a '#eval' decl.
+        evalCall = Eval $ App (Var mainRuleName) [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 () -> do
           case evalTrace of
-            [(Right (VRecord outputs), trace)] -> do
-              outputsFn' <- traverse (\(k, v) -> fmap (k,) (simalaValToFnLiteral v)) outputs
+            [(Right (VRecord outputRecord), trace)] -> do
               -- 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
+              let
+                filteredOutputs = maybe outputRecord (\keys -> filter (\(k, _) -> Set.member k keys) outputRecord) outputFilter
+
+              transformedOutputs <- traverse (\(k, v) -> fmap (k,) (simalaValToFnLiteral v)) filteredOutputs
               pure $
                 ResponseWithReason
-                  { responseValue = outputsFn
+                  { responseValue = transformedOutputs
                   , responseReasoning = Reasoning $ reasoningFromEvalTrace trace
                   }
-            (Left err, trace):_ -> do
-              liftIO $ Text.putStrLn $ Simala.renderFullTrace trace
+            (Left err, _trace) : _ -> do
+              -- TODO: add logging, this is a program that crashed during evaluation
               throwError $ InterpreterError $ "Unexpected output format: " <> Simala.render err
             _ -> throwError $ InterpreterError $ "Unexpected output format"
 
@@ -134,6 +144,10 @@ reasoningFromEvalTrace = go
   renderResult Nothing (Right x) = Simala.render x
   renderResult Nothing (Left x) = Simala.render x
 
+-- | Given a list of parameters with values, transform them to the 'simala'
+-- equivalent if possible.
+-- We map short names to their long forms, as we expect the program to
+-- exclusively use the long form.
 transformParameters :: (MonadIO m) => FunctionDeclaration -> [(Text, Maybe FnLiteral)] -> ExceptT EvaluatorError m (Row Expr)
 transformParameters decl attrs = do
   let
@@ -147,8 +161,8 @@ transformParameters decl attrs = do
         True -> pure key
       val <- case mValue of
         Nothing ->
-          -- null is resolved to 'uncertain per OIA convention
-          pure uncertain
+          -- null is resolved to 'unknown per OIA convention
+          pure unknown
         Just arg -> do
           fnLiteralToSimalaVar arg
 
@@ -161,22 +175,41 @@ transformParameters decl attrs = do
 
   let
     allInputs =
-      env <> fmap (,uncertain) parametersNotGiven
+      env <> fmap (,unknown) parametersNotGiven
   pure allInputs
- where
-  uncertain = Atom "uncertain"
 
 fnLiteralToSimalaVar :: (MonadIO m) => FnLiteral -> ExceptT EvaluatorError m Expr
 fnLiteralToSimalaVar = \case
   FnLitInt integer -> pure $ Lit $ FracLit $ fromIntegral integer
   FnLitDouble d -> pure $ Lit $ FracLit d
   FnLitBool b -> pure $ Lit $ BoolLit b
   FnLitString atom -> pure $ Atom atom
+  FnUncertain -> pure uncertain
+  FnUnknown -> pure unknown
 
-simalaValToFnLiteral :: (MonadIO m) => Val -> ExceptT EvaluatorError m FnLiteral
+simalaValToFnLiteral :: (Monad m) => Val -> ExceptT EvaluatorError m FnLiteral
 simalaValToFnLiteral = \case
   Simala.VInt integer -> pure $ FnLitInt $ fromIntegral integer
   Simala.VBool b -> pure $ FnLitBool b
-  Simala.VAtom atom -> pure $ FnLitString atom
+  Simala.VAtom atom
+    | uncertainName == atom -> pure FnUncertain
+    | unknownName == atom -> pure FnUnknown
+    | otherwise -> pure $ FnLitString atom
   Simala.VFrac f -> pure $ FnLitDouble f
-  val -> throwError $ InterpreterError $ "Cannot translate " <> Simala.render val
+  val -> throwError $ InterpreterError $ "Cannot translate \"" <> Simala.render val <> "\""
+
+-- ----------------------------------------------------------------------------
+-- Constants for function evaluation
+-- ----------------------------------------------------------------------------
+
+uncertain :: Expr
+uncertain = Atom uncertainName
+
+uncertainName :: Name
+uncertainName = "uncertain"
+
+unknown :: Expr
+unknown = Atom unknownName
+
+unknownName :: Name
+unknownName = "uncertain"

lib/haskell/web-service/src/Examples.hs

@@ -56,7 +56,7 @@ personQualifiesFunction = do
                 ]
         , supportedEvalBackend = [GenericMathLang, Simala]
         }
-  simalaEval <- Simala.simalaEvaluator (toDecl fnDecl) computeQualifiesSimala
+  simalaEval <- Simala.createSimalaFunction (toDecl fnDecl) computeQualifiesSimala
   pure $
     ValidatedFunction
       { fnImpl = fnDecl
@@ -104,7 +104,7 @@ rodentsAndVerminFunction = do
                 ]
         , supportedEvalBackend = [GenericMathLang, Simala]
         }
-  simalaEval <- Simala.simalaEvaluator (toDecl fnDecl) rodentsAndVerminSimala
+  simalaEval <- Simala.createSimalaFunction (toDecl fnDecl) rodentsAndVerminSimala
   pure $
     ValidatedFunction
       { fnImpl = fnDecl