aboutsummaryrefslogtreecommitdiffstats
path: root/lib/concepts
diff options
context:
space:
mode:
Diffstat (limited to 'lib/concepts')
-rw-r--r--lib/concepts/Condition.ml29
-rw-r--r--lib/concepts/Condition.mli14
-rw-r--r--lib/concepts/Hash.ml8
-rw-r--r--lib/concepts/Hash.mli13
-rw-r--r--lib/concepts/Path.ml16
-rw-r--r--lib/concepts/Path.mli8
-rw-r--r--lib/concepts/Representation.ml7
-rw-r--r--lib/concepts/Representation.mli13
-rw-r--r--lib/concepts/Tuple.ml46
-rw-r--r--lib/concepts/Tuple.mli9
-rw-r--r--lib/concepts/Value.ml6
-rw-r--r--lib/concepts/Value.mli9
12 files changed, 157 insertions, 21 deletions
diff --git a/lib/concepts/Condition.ml b/lib/concepts/Condition.ml
new file mode 100644
index 0000000..cc0f7a7
--- /dev/null
+++ b/lib/concepts/Condition.ml
@@ -0,0 +1,29 @@
+type properties = (string, Value.value) BatMap.t
+type ps = properties -> properties
+
+type condition =
+ {name: string; message: string; backtrace: Printexc.raw_backtrace; properties: properties}
+
+let ( |=| ) name value = fun p -> BatMap.add name value p
+let ( & ) l r = fun p -> r (l p)
+let empty = fun p -> p
+
+let condition name message ?parent props =
+ { name;
+ message;
+ backtrace= Printexc.get_callstack 256;
+ properties=
+ parent
+ |> Option.map (fun {properties; _} -> properties)
+ |> Option.value ~default:BatMap.empty
+ |> props }
+
+let to_string_hum {name; message; properties; backtrace} =
+ let properties' =
+ properties
+ |> BatMap.to_seq
+ |> BatSeq.to_string ~first:"" ~last:"" ~sep:"\n" (fun (k, v) ->
+ "\t" ^ k ^ ": " ^ Value.to_string v )
+ in
+ let backtrace' = Printexc.raw_backtrace_to_string backtrace in
+ name ^ ": " ^ message ^ "\n" ^ properties' ^ "\n\nBacktrace:\n" ^ backtrace'
diff --git a/lib/concepts/Condition.mli b/lib/concepts/Condition.mli
new file mode 100644
index 0000000..fba43e6
--- /dev/null
+++ b/lib/concepts/Condition.mli
@@ -0,0 +1,14 @@
+(** an abstract type representing an error condition *)
+type condition
+
+type ps
+
+val ( |=| ) : string -> Value.value -> ps
+val ( & ) : ps -> ps -> ps
+val empty : ps
+
+(** construct a condition out of a name, a message, a set of properties and an optional parent *)
+val condition : string -> string -> ?parent:condition -> ps -> condition
+
+(** print a condition to a human-readable string *)
+val to_string_hum : condition -> string
diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml
index 4c6cd8a..681ec4a 100644
--- a/lib/concepts/Hash.ml
+++ b/lib/concepts/Hash.ml
@@ -1,5 +1,5 @@
-type hash = ()
+type hash = bytes
-val hash_of_value (_: Value.value) = failwith "TODO"
-
-val hash_equals (_: hash) (_: hash) = failwith "TODO"
+let hash_of_value (_ : Value.value) = failwith "TODO"
+let hash_equals (_ : hash) (_ : hash) = failwith "TODO"
+let bytes_of_hash (h : hash) = h
diff --git a/lib/concepts/Hash.mli b/lib/concepts/Hash.mli
index dc25669..b100cd7 100644
--- a/lib/concepts/Hash.mli
+++ b/lib/concepts/Hash.mli
@@ -1,8 +1,11 @@
-(** An abstract value representing a hash *)
+(** an abstract value representing a hash *)
type hash
-(** Given a value, compute it's hash *)
-val hash_of_value: Value.value -> hash
+(** given a value, compute it's hash *)
+val hash_of_value : Value.value -> hash
-(** Given two hashes, are they the same? *)
-val hash_equals: hash -> hash -> bool
+(** given two hashes, are they the same? *)
+val hash_equals : hash -> hash -> bool
+
+(** given a hash, return a `bytes` representation of it *)
+val bytes_of_hash : hash -> bytes
diff --git a/lib/concepts/Path.ml b/lib/concepts/Path.ml
new file mode 100644
index 0000000..c751301
--- /dev/null
+++ b/lib/concepts/Path.ml
@@ -0,0 +1,16 @@
+type t = string BatFingerTree.t
+
+let empty : t = BatFingerTree.empty
+let of_list (components : string list) : t = BatFingerTree.of_list components
+let to_list (path : t) : string list = BatFingerTree.to_list path
+let snoc (path : t) (component : string) : t = BatFingerTree.snoc path component
+let to_string (path : t) : string = String.concat "/" (to_list path)
+
+let is_prefix ~(prefix : t) (path : t) : bool =
+ let rec walk prefix path =
+ match prefix, path with
+ | [], _ -> true
+ | p :: prefix, x :: path -> p = x && walk prefix path
+ | _ :: _, [] -> false
+ in
+ walk (to_list prefix) (to_list path)
diff --git a/lib/concepts/Path.mli b/lib/concepts/Path.mli
new file mode 100644
index 0000000..bec4221
--- /dev/null
+++ b/lib/concepts/Path.mli
@@ -0,0 +1,8 @@
+type t = string BatFingerTree.t
+
+val empty : t
+val of_list : string list -> t
+val to_list : t -> string list
+val snoc : t -> string -> t
+val to_string : t -> string
+val is_prefix : prefix:t -> t -> bool
diff --git a/lib/concepts/Representation.ml b/lib/concepts/Representation.ml
index 4df7812..d353a38 100644
--- a/lib/concepts/Representation.ml
+++ b/lib/concepts/Representation.ml
@@ -1,5 +1,6 @@
type blob = unit
-let blob_of_value (_: Value.value) = failwith "TODO"
-
-let value_of_blob (_: blob) = failwith "TODO"
+let blob_of_value (_ : Value.value) = failwith "TODO"
+let value_of_blob (_ : blob) = failwith "TODO"
+let blob_of_bytes (_ : bytes) = failwith "TODO"
+let bytes_of_blob (_ : blob) = failwith "TODO"
diff --git a/lib/concepts/Representation.mli b/lib/concepts/Representation.mli
index 9d0a8f5..21c43a4 100644
--- a/lib/concepts/Representation.mli
+++ b/lib/concepts/Representation.mli
@@ -2,6 +2,15 @@
type blob
(** encode a blob into a value *)
-val blob_of_value: Value.value -> blob
+val blob_of_value : Value.value -> blob
+
(** decode a value from a blob *)
-val value_of_blob: blob -> Value.value
+val value_of_blob : blob -> Value.value
+
+(* TODO: see the comments on Backend.Storage.LMDB *)
+
+(** create a blob from the data represented by bytes *)
+val blob_of_bytes : bytes -> blob
+
+(** return a bytes containing the data underlying a blob *)
+val bytes_of_blob : blob -> bytes
diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml
new file mode 100644
index 0000000..3050c13
--- /dev/null
+++ b/lib/concepts/Tuple.ml
@@ -0,0 +1,46 @@
+module AttributeMap = BatMap.String
+
+(** A tuple: a finite map from attribute name to attribute. *)
+type t = Value.value AttributeMap.t
+
+(** [empty] The tuple with no attributes. *)
+let empty : t = AttributeMap.empty
+
+(** [access name t] Looks up the attribute bound to [name] in [t].
+ @param name attribute name to look up.
+ @param t tuple to search.
+ @return the attribute, or [None] when [name] is unbound. *)
+let access (name : string) (t : t) : Value.value option = AttributeMap.find_opt name t
+
+(** [merge left right] Unions two tuples. Shared attributes take the
+ [left] value; one-sided attributes are kept. Precondition: shared
+ attributes agree (the natural-join matcher guarantees this), so the
+ [left] bias is never observable.
+ @param left first tuple.
+ @param right second tuple.
+ @return the merged tuple. *)
+let merge (left : t) (right : t) : t =
+ let merger _ (left : Value.value option) (right : Value.value option) : Value.value option =
+ match left, right with (Some _ as v), _ | None, (Some _ as v) -> v | None, None -> None
+ in
+ AttributeMap.merge merger left right
+
+(** [project keep t] Keeps only the attributes of [t] whose names are
+ in [keep].
+ @param keep set of attribute names to retain.
+ @param t tuple to project.
+ @return the projected tuple. *)
+let project (keep : BatSet.String.t) (t : t) : t =
+ AttributeMap.filter (fun name _ -> BatSet.String.mem name keep) t
+
+(** [rename mapping t] Renames the attributes of [t] through
+ [mapping]; names absent from [mapping] are left unchanged.
+ @param mapping map from old name to new name.
+ @param t tuple to rename.
+ @return the renamed tuple. *)
+let rename (mapping : string BatMap.String.t) (t : t) : t =
+ AttributeMap.fold
+ (fun name attr acc ->
+ let name = BatMap.String.find_default name name mapping in
+ AttributeMap.add name attr acc )
+ t AttributeMap.empty
diff --git a/lib/concepts/Tuple.mli b/lib/concepts/Tuple.mli
new file mode 100644
index 0000000..07f7a24
--- /dev/null
+++ b/lib/concepts/Tuple.mli
@@ -0,0 +1,9 @@
+module AttributeMap = BatMap.String
+
+type t = Value.value AttributeMap.t
+
+val empty : t
+val access : string -> t -> Value.value option
+val merge : t -> t -> t
+val project : BatSet.String.t -> t -> t
+val rename : string BatMap.String.t -> t -> t
diff --git a/lib/concepts/Value.ml b/lib/concepts/Value.ml
index 3e57717..65a0439 100644
--- a/lib/concepts/Value.ml
+++ b/lib/concepts/Value.ml
@@ -1,3 +1,3 @@
-type value
- = String of string
- | Integer of int
+type value = String of string | Integer of int
+
+let to_string = function String s -> s | Integer n -> Int.to_string n
diff --git a/lib/concepts/Value.mli b/lib/concepts/Value.mli
index 6cb09ad..9644443 100644
--- a/lib/concepts/Value.mli
+++ b/lib/concepts/Value.mli
@@ -1,4 +1,5 @@
-(** A tagged concrete value *)
-type value
- = String of string
- | Integer of int
+(** a tagged concrete value *)
+type value = String of string | Integer of int
+
+(** given a value, return a string representation of it *)
+val to_string : value -> string
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 12:07:29 +0000