Some scaffolding for sublanguage tests (#72)

* No need to take the multigroup name as an argument

* Record backtraces when instantiating conditions

* Equality for abstract values

* Move `make_ctx` out of the listener

* Include the return code on `handle-error` conditions

* Do not include brackets around stringified condition properties

* Equality for materialized attributes

* Equality for materialized tuples

* Scaffolding for a test suite

9 files changed, 105 insertions, 67 deletions

diff --git a/lib/attribute.ml b/lib/attribute.ml
index b828d64..8448bee 100644
--- a/lib/attribute.ml
+++ b/lib/attribute.ml
@@ -9,3 +9,5 @@ let make_referenced ~value =
   Referenced { value_hash }
 
 let make_materialized ~value = Materialized { value }
+
+let materialized_equal a b = Conventions.AbstractValue.equal a.value b.value
diff --git a/lib/branch.ml b/lib/branch.ml
index 0b28663..f606d3f 100644
--- a/lib/branch.ml
+++ b/lib/branch.ml
@@ -96,7 +96,7 @@ module Make (NT : Nt.S) = struct
       let* mg_val = self#get_mg "create_relation" mg in
       let* (bh', mg') =
         NT.create_relation bh mg_val
-          ~branch_name:name ~mg_name:mg ~name:rel_name ~schema
+          ~branch_name:name ~name:rel_name ~schema
       in
       bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok ()
 
diff --git a/lib/condition.ml b/lib/condition.ml
index 44ef2ff..83ae9b8 100644
--- a/lib/condition.ml
+++ b/lib/condition.ml
@@ -11,16 +11,19 @@ end
 
 let of_sexp (expr : Sexplib.Sexp.t) = new literal expr
 let of_string (s : string) = new literal (Sexplib.Sexp.Atom s)
+let of_int (n : int) = of_string (Int.to_string n)
 let of_list (f : 'a -> serializable) (l : 'a list) : serializable =
   new literal (Sexplib.Sexp.List (List.map (fun e -> (f e)#as_sexp) l))
 
 type t = { name : string;
            message : string;
+           backtrace : Printexc.raw_backtrace;
            properties : (string, serializable) BatMap.t }
 
 let condition name message ?parent props =
   { name;
     message;
+    backtrace = Printexc.get_callstack 64;
     properties =
       parent
       |> Option.map (fun { properties; _ } -> properties)
@@ -31,7 +34,7 @@ let ( |=| ) name value = (fun p -> BatMap.add name value p)
 let ( & ) l r = (fun p -> r (l p))
 let empty = (fun p -> p)
 
-let to_sexp { name; message; properties } =
+let to_sexp { name; message; properties; _ } =
   let open Sexplib.Sexp in
   let properties' =
     properties
@@ -40,10 +43,13 @@ let to_sexp { name; message; properties } =
     |> BatList.of_seq in
   List (Atom name :: Atom message :: properties')
 
-let to_string { name; message; properties } =
+let to_string { name; message; properties; backtrace } =
   let properties' =
     properties
     |> BatMap.to_seq
-    |> BatSeq.to_string ~sep:"\n" (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string)
+    |> BatSeq.to_string
+         ~first:"" ~last:"" ~sep:"\n"
+         (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string)
   in
-  name ^ ": " ^ message ^ properties'
+  let backtrace' = Printexc.raw_backtrace_to_string backtrace in
+  name ^ ": " ^ message ^ "\n" ^ properties' ^ "\n\nBacktrace:\n" ^ backtrace'
diff --git a/lib/conventions.ml b/lib/conventions.ml
index fe85737..9e18762 100644
--- a/lib/conventions.ml
+++ b/lib/conventions.ml
@@ -25,19 +25,35 @@ end
 
 module AbstractValue = struct
   type t = Obj.t
+  type value_type = Int | String | Float | Opaque
 
   let hash (elem : t) =
     Sha256.to_hex (Sha256.string (Bytes.to_string (Marshal.to_bytes elem [])))
 
+  let type_of (elem : t) : value_type =
+    let tag = Obj.tag elem in
+    if Obj.is_int elem then Int
+    else if tag = Obj.string_tag then String
+    else if tag = Obj.double_tag then Float
+    else Opaque
+
   let sexp_of_t (v : t) =
     let open Sexplib.Sexp in
-    if Obj.is_int v then Atom (string_of_int (Obj.obj v : int))
-    else
-      let tag = Obj.tag v in
-      if tag = Obj.string_tag then Atom (Obj.obj v : string)
-      else if tag = Obj.double_tag then
-        let f = (Obj.obj v : float) in
-        if Float.is_nan f || Float.is_infinite f then Atom "nan"
-        else Atom (string_of_float f)
-      else Atom "<opaque>"
+    match type_of v with
+    | Int -> Atom (string_of_int (Obj.obj v : int))
+    | String -> Atom (Obj.obj v : string)
+    | Float ->
+       let f = (Obj.obj v : float) in
+       if Float.is_nan f || Float.is_infinite f
+       then Atom "nan"
+       else Atom (string_of_float f)
+    | Opaque -> Atom "<opaque>"
+
+  let equal a b =
+    match (type_of a, type_of b) with
+    | (Int, Int) -> (Obj.obj a : int) = (Obj.obj b : int)
+    | (String, String) -> (Obj.obj a : string) = (Obj.obj b : string)
+    | (Float, Float) -> (Obj.obj a : float) = (Obj.obj b : float)
+    | (Opaque, Opaque) -> false
+    | (_, _) -> false
 end
diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml
index c61b02e..a47c911 100644
--- a/lib/ddl/executor.ml
+++ b/lib/ddl/executor.ml
@@ -46,8 +46,7 @@ module Make (NT : Nt.S) = struct
             Schema.empty schema_pairs
         in
         let* _bh, new_mg =
-          NT.create_relation bh mg
-            ~branch_name ~mg_name:fqn.mg ~name:fqn.name ~schema
+          NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema
         in
         ctx.branch#set_mg ~name:fqn.mg new_mg;
         Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name)
diff --git a/lib/listener.ml b/lib/listener.ml
index ba61a50..b3090a7 100644
--- a/lib/listener.ml
+++ b/lib/listener.ml
@@ -8,6 +8,7 @@ functor
 
     module Sess = Session.Make (NT)
     module B    = Branch.Make (NT)
+    module SC   = Sublanguage_context.Make (NT)
 
     module Error = struct
       open Condition
@@ -37,30 +38,8 @@ functor
         state. Called at the top of every handle_sublanguage so it
         always reflects the live branch after any prior VCL
         switch. **)
-    let make_ctx (state : conn_state) : Sublanguage_context.t =
-      let br      = state.session#branch in
-      let claims  = state.claims in
-      let session = state.session in
-      {
-        Sublanguage_context.write_handle  = br#branch_handle;
-        branch                            = (br :> Sublanguage_context.branch_view);
-        resolve                           = br#path;
-        switch_branch = fun name ->
-          match br#close () with
-          | Error e -> Error e
-          | Ok () ->
-              begin match B.open_branch claims name with
-               | Error e ->
-                  begin match B.open_branch claims "master" with
-                  | Ok mbr -> session#set_branch mbr
-                  | Error _ -> ()
-                  end;
-                  Error e
-               | Ok new_br ->
-                   session#set_branch new_br;
-                   Ok new_br#multigroups
-              end
-      }
+    let make_ctx ({ session; claims } : conn_state) : Sublanguage_context.t =
+      SC.make_ctx session claims
 
     let read_command input =
       try Ok (Sexplib.Sexp.input_sexp input)
diff --git a/lib/nt.ml b/lib/nt.ml
index 8622110..3882288 100644
--- a/lib/nt.ml
+++ b/lib/nt.ml
@@ -38,7 +38,10 @@ module Error = struct
   open Condition
   (* TODO: better error structure *)
   let auth_failed msg = condition "auth-failed" msg empty
-  let handle_error msg = condition "handle-error" msg empty
+  let handle_error rc msg = condition "handle-error" msg ("return-code" |=| (of_int rc))
+  let object_not_found kind id = condition "object-not-found" "Object not found"
+                                   ("kind" |=| (of_string kind) &
+                                    "identifier" |=| (of_string id))
   let cursor_error msg = condition "cursor-error" msg empty
   let not_supported msg = condition "not-supported" msg empty
   let initialization_error = condition "initialization-error" "Couldn't initialize" empty
@@ -118,7 +121,7 @@ module Make (B : Backend) = struct
     match (rc, target_opt) with
     | (0, Some s) -> Ok s
     | (0, None)   -> Ok ""
-    | _           -> Error (Error.handle_error "branch_target read failed")
+    | _           -> Error (Error.handle_error rc "branch_target read failed")
 
   let list_relations ~(branch_name : string) ~(mg_name : string) :
       ((string * string) list, Condition.t) result =
@@ -137,7 +140,7 @@ module Make (B : Backend) = struct
         in
         Ok pairs
     | (0, None)   -> Ok []
-    | _           -> Error (Error.handle_error
+    | _           -> Error (Error.handle_error rc
                               ("list_relations failed: " ^ branch_name
                                ^ "/" ^ mg_name))
 
@@ -159,7 +162,7 @@ module Make (B : Backend) = struct
         in
         Ok pairs
     | (0, None)   -> Ok []
-    | _           -> Error (Error.handle_error
+    | _           -> Error (Error.handle_error rc
                               ("list_branch_multigroups failed: " ^ branch_name))
 
   let session_open () : (string, Condition.t) result =
@@ -169,16 +172,16 @@ module Make (B : Backend) = struct
     in
     match (rc, id_opt) with
     | (0, Some id) -> Ok id
-    | _            -> Error (Error.handle_error "session_open failed")
+    | _            -> Error (Error.handle_error rc "session_open failed")
 
   let session_close (sid : string) : (unit, Condition.t) result =
     let rc = Nt_ffi.rnt_session_close sid in
-    if rc = 0 then Ok () else Error (Error.handle_error "session_close failed")
+    if rc = 0 then Ok () else Error (Error.handle_error rc "session_close failed")
 
   let session_set_branch (sid : string) (branch_name : string)
       (target_hash : string) : (unit, Condition.t) result =
     let rc = Nt_ffi.rnt_session_set_branch sid branch_name target_hash in
-    if rc = 0 then Ok () else Error (Error.handle_error "session_set_branch failed")
+    if rc = 0 then Ok () else Error (Error.handle_error rc "session_set_branch failed")
 
   let open_branch (_claims : claims) (name : string) :
       (branch_handle * Management.Multigroup.multigroup, Condition.t) result =
@@ -186,7 +189,7 @@ module Make (B : Backend) = struct
     ensure_branch path;
     let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in
     match Nt_ffi.ptr_to_opt raw with
-    | None -> Error (Error.handle_error ("branch not found: " ^ name))
+    | None -> Error (Error.object_not_found "branch" name)
     | Some bh ->
         let* _tip          = branch_target_of_handle bh in
         let* rel_entries   = list_relations ~branch_name:name ~mg_name:name in
@@ -216,7 +219,7 @@ module Make (B : Backend) = struct
 
   let close_branch (bh : branch_handle) : (unit, Condition.t) result =
     let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh) in
-    if rc = 0 then Ok () else Error (Error.handle_error "close_branch failed")
+    if rc = 0 then Ok () else Error (Error.handle_error rc "close_branch failed")
 
   let list_snapshot_relations (snapshot_hash : string) :
       ((string * string) list, Condition.t) result =
@@ -235,7 +238,7 @@ module Make (B : Backend) = struct
         in
         Ok pairs
     | (0, None)   -> Ok []
-    | _           -> Error (Error.handle_error ("list_snapshot_relations failed: " ^ snapshot_hash))
+    | _           -> Error (Error.handle_error rc ("list_snapshot_relations failed: " ^ snapshot_hash))
 
   (* Opens a read-only view pinned to a specific snapshot hash.
      Returns (bh, mg) where bh is a handle on the snapshot object and mg
@@ -247,7 +250,7 @@ module Make (B : Backend) = struct
     let snap_path = "/system/snapshots/" ^ snapshot_hash in
     let raw = Nt_ffi.rnt_open_handle snap_path (from_voidp void null) in
     match Nt_ffi.ptr_to_opt raw with
-    | None -> Error (Error.handle_error ("snapshot not found: " ^ snapshot_hash))
+    | None -> Error (Error.object_not_found "snapshot" snapshot_hash)
     | Some bh ->
         let* rel_entries = list_snapshot_relations snapshot_hash in
         let mg =
@@ -281,12 +284,12 @@ module Make (B : Backend) = struct
     ignore (Nt_ffi.rnt_register_relation path);
     let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in
     match Nt_ffi.ptr_to_opt raw with
-    | None -> Error (Error.handle_error ("relation not found: " ^ rel_name))
+    | None -> Error (Error.object_not_found "relation" rel_name)
     | Some rh -> Ok rh
 
   let close_relation (rh : relation_handle) : (unit, Condition.t) result =
     let rc = Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr rh) in
-    if rc = 0 then Ok () else Error (Error.handle_error "close_relation failed")
+    if rc = 0 then Ok () else Error (Error.handle_error rc "close_relation failed")
 
   (* --------------------------------------------------------------------------
      Query execution via the Tarski VM plan builder
@@ -395,12 +398,12 @@ module Make (B : Backend) = struct
     open_branch claims name
 
   let create_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup)
-      ~(branch_name : string) ~(mg_name : string) ~(name : string)
-      ~(schema : Schema.t) :
+      ~(branch_name : string) ~(name : string) ~(schema : Schema.t) :
       (branch_handle * Management.Multigroup.multigroup, Condition.t) result =
+    let mg_name = mg#name in
     let path = relation_path ~branch_name ~mg_name ~rel_name:name in
     let rc   = Nt_ffi.rnt_register_relation path in
-    if rc <> 0 then Error (Error.handle_error ("register_relation failed: " ^ name))
+    if rc <> 0 then Error (Error.handle_error rc ("register_relation failed: " ^ name))
     else
       let rel_root =
         let (rc, opt) =
@@ -437,7 +440,7 @@ module Make (B : Backend) = struct
       (branch_handle * Management.Multigroup.multigroup, Condition.t) result =
     let path = relation_path ~branch_name ~mg_name ~rel_name:rel#name in
     let rc = Nt_ffi.rnt_clear_relation path in
-    if rc <> 0 then Error (Error.handle_error ("clear_relation failed: " ^ rel#name))
+    if rc <> 0 then Error (Error.handle_error rc ("clear_relation failed: " ^ rel#name))
     else
       let* _tip = branch_target_of_handle bh in
       Ok (bh, mg)
@@ -470,7 +473,7 @@ module Make (B : Backend) = struct
       ~(body : Constraint.t) :
       (branch_handle * Management.Multigroup.multigroup, Condition.t) result =
     match mg#get_relation relation_name with
-    | None -> Error (Error.handle_error ("relation not found: " ^ relation_name))
+    | None -> Error (Error.object_not_found "relation" relation_name)
     | Some rel ->
         let existing =
           match rel#constraints with Some cs -> cs | None -> []
@@ -501,7 +504,7 @@ module Make (B : Backend) = struct
     in
     match (rc, hash_opt) with
     | (0, Some h) -> Ok h
-    | _           -> Error (Error.handle_error "insert_tuple failed")
+    | _           -> Error (Error.handle_error rc "insert_tuple failed")
 
   let create_tuple ~branch_name ~mg_name ~rel_name (tuple : Tuple.materialized) :
       (string, Condition.t) result =
@@ -520,7 +523,7 @@ module Make (B : Backend) = struct
       (unit, Condition.t) result =
     let path = relation_path ~branch_name ~mg_name ~rel_name in
     let rc = Nt_ffi.rnt_unlink_tuple path hash in
-    if rc = 0 then Ok () else Error (Error.handle_error "retract_tuple failed")
+    if rc = 0 then Ok () else Error (Error.handle_error rc "retract_tuple failed")
 
   let relation_root ~(branch_name : string) ~(mg_name : string)
       ~(rel_name : string) : (string, Condition.t) result =
@@ -531,7 +534,7 @@ module Make (B : Backend) = struct
     match (rc, root_opt) with
     | (0, Some r) -> Ok r
     | (0, None)   -> Ok ""
-    | _           -> Error (Error.handle_error "relation_root query failed")
+    | _           -> Error (Error.handle_error rc "relation_root query failed")
 
   (* --------------------------------------------------------------------------
      Prelude / catalog bootstrap
@@ -551,7 +554,7 @@ module Make (B : Backend) = struct
         (fun acc (name, schema) ->
           let* (branch_handle, multigroup) = acc in
           create_relation branch_handle multigroup
-            ~branch_name ~mg_name ~name ~schema)
+            ~branch_name ~name ~schema)
         (Ok (branch_handle, multigroup))
         Prelude.Catalog.catalog_definitions
     in
@@ -589,7 +592,7 @@ module Make (B : Backend) = struct
     ensure_branch path;
     let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in
     match Nt_ffi.ptr_to_opt raw with
-    | None -> Error (Error.handle_error "init: could not open master branch")
+    | None -> Error (Error.object_not_found "branch" "master")
     | Some bh ->
         let* target = branch_target_of_handle bh in
         let result =
@@ -598,9 +601,8 @@ module Make (B : Backend) = struct
               new Management.Multigroup.multigroup
                 ~name:Prelude.Catalog.prelude_mg
             in
-            (match seed_prelude ~branch_name:"master" bh mg with
-             | Ok _    -> Ok ()
-             | Error e -> Error e)
+            seed_prelude ~branch_name:"master" bh mg
+            |> Result.map ignore
           else Ok ()
         in
         ignore (Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh));
@@ -666,7 +668,7 @@ module type S = sig
   val get_relation : Management.Multigroup.multigroup -> string -> Relation.ephemeral option
 
   val create_multigroup : claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
-  val create_relation   : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
+  val create_relation   : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
   val retract_relation  : branch_handle -> Management.Multigroup.multigroup -> name:string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
   val clear_relation    : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> Relation.relation -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
   val register_domain   : branch_handle -> Management.Multigroup.multigroup -> Relation.domain -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result
diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml
index aca5790..39e6dd3 100644
--- a/lib/sublanguage_context.ml
+++ b/lib/sublanguage_context.ml
@@ -37,3 +37,34 @@ type t = {
   switch_branch : string ->
                   (Sublanguage_types.transition_delta, Condition.t) result;
 }
+
+module Make (NT : Nt.S) = struct
+  module Session = Session.Make (NT)
+  module Branch = Branch.Make (NT)
+
+  let make_ctx
+        (session : Session.session)
+        (claims : string)
+      : t =
+    let br = session#branch in
+    {
+      write_handle  = br#branch_handle;
+      branch                            = (br :> branch_view);
+      resolve                           = br#path;
+      switch_branch = fun name ->
+                      match br#close () with
+                      | Error e -> Error e
+                      | Ok () ->
+                         begin match Branch.open_branch claims name with
+                         | Error e ->
+                            begin match Branch.open_branch claims "master" with
+                            | Ok mbr -> session#set_branch mbr
+                            | Error _ -> ()
+                            end;
+                            Error e
+                         | Ok new_br ->
+                            session#set_branch new_br;
+                            Ok new_br#multigroups
+                         end
+    }
+end
diff --git a/lib/tuple.ml b/lib/tuple.ml
index 24eecab..ffeb3c9 100644
--- a/lib/tuple.ml
+++ b/lib/tuple.ml
@@ -32,3 +32,6 @@ let make_materialized ~relation ~attributes =
       attributes;
       (* lineage = None *)
     }
+
+let materialized_equal a b =
+  AttributeMap.equal Attribute.materialized_equal a.attributes b.attributes