Evaluate typed queries over persistent maps

src/interpret.ml

@@ -0,0 +1,140 @@
+type env = {
+  helpers : (int * Typed.expr) list;
+  values : (int * Value.t) list;
+}
+
+let empty_env helpers = { helpers = helpers; values = [] }
+
+let helpers_of_program program =
+  List.map
+    (fun helper -> (Ident.stamp helper.Typed.th_ident, helper.Typed.th_body))
+    program.Typed.tp_helpers
+
+let bind env ident value = { env with values = (Ident.stamp ident, value) :: env.values }
+
+let lookup env ident =
+  let rec search = function
+    | [] -> None
+    | (stamp, value) :: rest -> if stamp = Ident.stamp ident then Some value else search rest
+  in
+  search env.values
+
+let int_of span value =
+  match value with
+  | Value.VInt number -> number
+  | other -> Diagnostic.error span "runtime error: expected an integer but got %s" (Value.to_string other)
+
+let bool_of span value =
+  match value with
+  | Value.VBool truth -> truth
+  | other -> Diagnostic.error span "runtime error: expected a boolean but got %s" (Value.to_string other)
+
+let collection_of span value =
+  match value with
+  | Value.VCollection map -> map
+  | other -> Diagnostic.error span "runtime error: expected a collection but got %s" (Value.to_string other)
+
+let rec eval env expr =
+  let span = expr.Typed.tspan in
+  match expr.Typed.te with
+  | Typed.TInt value -> Value.VInt value
+  | Typed.TBool value -> Value.VBool value
+  | Typed.TString value -> Value.VString value
+  | Typed.TUnit -> Value.VUnit
+  | Typed.TVar ident -> (
+      match lookup env ident with
+      | Some value -> value
+      | None -> Diagnostic.error span "runtime error: `%s` has no value" (Ident.display ident))
+  | Typed.TSource ident -> (
+      match lookup env ident with
+      | Some value -> value
+      | None -> Diagnostic.error span "runtime error: the input collection has no value")
+  | Typed.TLet (ident, bound, body) -> eval (bind env ident (eval env bound)) body
+  | Typed.TLambda _ ->
+      Diagnostic.error span "runtime error: a function cannot be used as a value"
+  | Typed.TApp (fn, argument) -> apply env fn (eval env argument)
+  | Typed.TIf (condition, then_branch, else_branch) ->
+      if bool_of condition.Typed.tspan (eval env condition) then eval env then_branch
+      else eval env else_branch
+  | Typed.TBinop (Syntax.And, left, right) ->
+      if bool_of left.Typed.tspan (eval env left) then Value.VBool (bool_of right.Typed.tspan (eval env right))
+      else Value.VBool false
+  | Typed.TBinop (Syntax.Or, left, right) ->
+      if bool_of left.Typed.tspan (eval env left) then Value.VBool true
+      else Value.VBool (bool_of right.Typed.tspan (eval env right))
+  | Typed.TBinop (operator, left, right) ->
+      eval_binop span operator (eval env left) (eval env right)
+  | Typed.TTuple items -> Value.VTuple (List.map (eval env) items)
+  | Typed.TRecord (name, fields) ->
+      Value.VRecord (name, List.map (fun (label, value) -> (label, eval env value)) fields)
+  | Typed.TField (record, label) -> (
+      match Value.field (eval env record) label with
+      | Some value -> value
+      | None -> Diagnostic.error span "runtime error: the record has no field `%s`" label)
+  | Typed.TFilter (collection, predicate) ->
+      let map = collection_of collection.Typed.tspan (eval env collection) in
+      let kept =
+        Delta_runtime.Pure_map.fold
+          (fun key value acc ->
+            if bool_of predicate.Typed.tspan (apply env predicate value) then
+              Delta_runtime.Pure_map.add key value acc
+            else acc)
+          map Delta_runtime.Pure_map.empty
+      in
+      Value.VCollection kept
+  | Typed.TMap (collection, projection) ->
+      let map = collection_of collection.Typed.tspan (eval env collection) in
+      let mapped =
+        Delta_runtime.Pure_map.fold
+          (fun key value acc ->
+            Delta_runtime.Pure_map.add key (apply env projection value) acc)
+          map Delta_runtime.Pure_map.empty
+      in
+      Value.VCollection mapped
+  | Typed.TSum collection ->
+      let map = collection_of collection.Typed.tspan (eval env collection) in
+      let total =
+        Delta_runtime.Pure_map.fold
+          (fun _ value acc -> acc + int_of collection.Typed.tspan value)
+          map 0
+      in
+      Value.VInt total
+  | Typed.TCount collection ->
+      let map = collection_of collection.Typed.tspan (eval env collection) in
+      Value.VInt (Delta_runtime.Pure_map.cardinal map)
+
+and apply env fn argument =
+  match fn.Typed.te with
+  | Typed.TLambda (ident, body) -> eval (bind env ident argument) body
+  | Typed.TVar ident -> (
+      match Util.assoc_opt (Ident.stamp ident) env.helpers with
+      | Some body -> apply env body argument
+      | None ->
+          Diagnostic.error fn.Typed.tspan "runtime error: `%s` is not a function" (Ident.display ident))
+  | _ -> Diagnostic.error fn.Typed.tspan "runtime error: this expression is not a function"
+
+and eval_binop span operator left right =
+  match operator with
+  | Syntax.Add -> Value.VInt (int_of span left + int_of span right)
+  | Syntax.Sub -> Value.VInt (int_of span left - int_of span right)
+  | Syntax.Mul -> Value.VInt (int_of span left * int_of span right)
+  | Syntax.Div -> Value.VInt (int_of span left / int_of span right)
+  | Syntax.Eq -> Value.VBool (Value.equal left right)
+  | Syntax.Ne -> Value.VBool (not (Value.equal left right))
+  | Syntax.Lt -> Value.VBool (int_of span left < int_of span right)
+  | Syntax.Le -> Value.VBool (int_of span left <= int_of span right)
+  | Syntax.Gt -> Value.VBool (int_of span left > int_of span right)
+  | Syntax.Ge -> Value.VBool (int_of span left >= int_of span right)
+  | Syntax.And | Syntax.Or -> Diagnostic.error span "runtime error: boolean operator evaluated eagerly"
+
+let call env fn argument = apply env fn argument
+
+let program typed input =
+  let map = Value.collection_of_list input in
+  let env =
+    {
+      helpers = helpers_of_program typed;
+      values = [ (Ident.stamp typed.Typed.tp_input, Value.VCollection map) ];
+    }
+  in
+  eval env typed.Typed.tp_query_body

src/interpret.mli

@@ -0,0 +1,11 @@
+type env = {
+  helpers : (int * Typed.expr) list;
+  values : (int * Value.t) list;
+}
+
+val empty_env : (int * Typed.expr) list -> env
+val helpers_of_program : Typed.program -> (int * Typed.expr) list
+val bind : env -> Ident.t -> Value.t -> env
+val eval : env -> Typed.expr -> Value.t
+val call : env -> Typed.expr -> Value.t -> Value.t
+val program : Typed.program -> (int * Value.t) list -> Value.t

src/value.ml

@@ -0,0 +1,45 @@
+type t =
+  | VUnit
+  | VInt of int
+  | VBool of bool
+  | VString of string
+  | VTuple of t list
+  | VRecord of string * (string * t) list
+  | VCollection of t Delta_runtime.Pure_map.t
+
+let rec to_string value =
+  match value with
+  | VUnit -> "unit"
+  | VInt number -> string_of_int number
+  | VBool true -> "true"
+  | VBool false -> "false"
+  | VString text -> Printf.sprintf "%S" text
+  | VTuple items -> "(tuple " ^ Util.join " " (List.map to_string items) ^ ")"
+  | VRecord (name, fields) ->
+      Printf.sprintf "(record:%s %s)" name
+        (Util.join " " (List.map (fun (label, field) -> "(" ^ label ^ " " ^ to_string field ^ ")") fields))
+  | VCollection map ->
+      let entries =
+        List.map (fun (key, item) -> Printf.sprintf "(%d %s)" key (to_string item))
+          (Delta_runtime.Pure_map.bindings map)
+      in
+      "(collection " ^ Util.join " " entries ^ ")"
+
+let collection_of_list entries =
+  List.fold_left
+    (fun map (key, value) ->
+      if Delta_runtime.Pure_map.mem key map then
+        Diagnostic.error Location.none "duplicate key %d in the initial input" key;
+      Delta_runtime.Pure_map.add key value map)
+    Delta_runtime.Pure_map.empty entries
+
+let collection_to_list map = Delta_runtime.Pure_map.bindings map
+
+let equal (left : t) (right : t) = left = right
+
+let field record label =
+  match record with
+  | VRecord (_, fields) -> Util.assoc_opt label fields
+  | _ -> None
+
+let is_collection = function VCollection _ -> true | _ -> false

src/value.mli

@@ -0,0 +1,15 @@
+type t =
+  | VUnit
+  | VInt of int
+  | VBool of bool
+  | VString of string
+  | VTuple of t list
+  | VRecord of string * (string * t) list
+  | VCollection of t Delta_runtime.Pure_map.t
+
+val to_string : t -> string
+val collection_of_list : (int * t) list -> t Delta_runtime.Pure_map.t
+val collection_to_list : t Delta_runtime.Pure_map.t -> (int * t) list
+val equal : t -> t -> bool
+val field : t -> string -> t option
+val is_collection : t -> bool