Include messages on on all conditions

25 files changed, 65 insertions, 56 deletions

diff --git a/lib/branch.ml b/lib/branch.ml
index d81702f..0b28663 100644
--- a/lib/branch.ml
+++ b/lib/branch.ml
@@ -6,8 +6,8 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let not_supported msg = condition "not-supported" ("message" |=| (of_string msg))
-    let handle_error msg = condition "handle-error" ("message" |=| (of_string msg))
+    let not_supported msg = condition "not-supported" msg empty
+    let handle_error msg = condition "handle-error" msg empty
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/condition.ml b/lib/condition.ml
index 67915b6..9c98df0 100644
--- a/lib/condition.ml
+++ b/lib/condition.ml
@@ -12,10 +12,13 @@ let of_string (s : string) = new literal (Sexplib.Sexp.Atom s)
 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; properties : (string, serializable) BatMap.t }
+type t = { name : string;
+           message : string;
+           properties : (string, serializable) BatMap.t }
 
-let condition name ?parent props =
+let condition name message ?parent props =
   { name;
+    message;
     properties =
       parent
       |> Option.map (fun { properties; _ } -> properties)
@@ -26,13 +29,13 @@ 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; properties } =
+let to_sexp { name; message; properties } =
   let open Sexplib.Sexp in
   let properties' =
     BatMap.to_seq properties
     |> BatSeq.map (fun (k, v) -> List [Atom k; v#as_sexp])
     |> BatList.of_seq in
-  List (Atom name :: properties')
+  List (Atom name :: Atom message :: properties')
 
 let to_string e =               (* FIXME *)
   Sexplib.Sexp.to_string_hum (to_sexp e)
diff --git a/lib/configuration.ml b/lib/configuration.ml
index 151644e..12a3681 100644
--- a/lib/configuration.ml
+++ b/lib/configuration.ml
@@ -6,21 +6,28 @@ end
 
 module Error = struct
   open Condition
-  let unknown_section key = condition "unknown-section" ("key" |=| (of_string key))
-  let duplicate_section key = condition "duplicate-section" ("key" |=| (of_string key))
-  let empty_section key = condition "empty-section" ("key" |=| (of_string key))
-  let multiple_values_in_section key = condition "multiple-values-in-section" ("key" |=| (of_string key))
-  let invalid_toplevel toplevel = condition "invalid-toplevel" ("expression" |=| (of_sexp toplevel))
-  let malformed_section expr = condition "malformed-section" ("expression" |=| (of_sexp expr))
-  let missing_section name = condition "missing-section" ("name" |=| (of_string name))
-  let invalid_tag section tag valid_options = condition "invalid-tag"
+  let unknown_section key = condition "unknown-section" "Unknown configuration section"
+                              ("key" |=| (of_string key))
+  let duplicate_section key = condition "duplicate-section" "Duplicate configuration section"
+                                ("key" |=| (of_string key))
+  let empty_section key = condition "empty-section" "Empty configuration section (expected a tagged value)"
+                            ("key" |=| (of_string key))
+  let multiple_values_in_section key = condition "multiple-values-in-section" "Configuration section contains multiple values (expected exactly one)"
+                                         ("key" |=| (of_string key))
+  let invalid_toplevel toplevel = condition "invalid-toplevel" "Configuration must be a (server ...) s-expression"
+                                    ("expression" |=| (of_sexp toplevel))
+  let malformed_section expr = condition "malformed-section" "Section must be a (tag ...) s-expression"
+                                 ("expression" |=| (of_sexp expr))
+  let missing_section name = condition "missing-section" "Missing section in configuration"
+                               ("name" |=| (of_string name))
+  let invalid_tag section tag valid_options = condition "invalid-tag" "Invalid tag for section"
                                                 ("section" |=| (of_string section) &
                                                  "tag" |=| (of_string tag) &
                                                  "valid-options" |=| (of_list of_string valid_options))
-  let failed_to_load_file path msg = condition "failed-to-load-file"
+  let failed_to_load_file path msg = condition "failed-to-load-file" "Failed to load configuration file"
                                        ("path" |=| (of_string path) &
                                         "message" |=| (of_string msg))
-  let syntax_error path msg = condition "syntax-error"
+  let syntax_error path msg = condition "syntax-error" "Failed to parse configuration file"
                                 ("path" |=| (of_string path) &
                                  "message" |=| (of_string msg))
 end
diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml
index de64cf5..c61b02e 100644
--- a/lib/ddl/executor.ml
+++ b/lib/ddl/executor.ml
@@ -2,8 +2,8 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let relation_not_found name = condition "relation-not-found" ("name" |=| (of_string name))
-    let multigroup_not_found name = condition "multigroup-not-found" ("name" |=| (of_string name))
+    let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name))
+    let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name))
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml
index 49fa7e0..a4df914 100644
--- a/lib/ddl/parser.ml
+++ b/lib/ddl/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let of_sexp sexp =
diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml
index f149965..c35f128 100644
--- a/lib/dml/executor.ml
+++ b/lib/dml/executor.ml
@@ -4,10 +4,9 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
-    let relation_not_found name = condition "relation-not-found" ("name" |=| (of_string name))
-    let multigroup_not_found name = condition "multigroup-not-found" ("name" |=| (of_string name))
-    let unqualified_name name = condition "unqualified-name" ("name" |=| (of_string name))
+    let parse_error msg = condition "parse-error" msg empty
+    let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name))
+    let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name))
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml
index 49fa7e0..a4df914 100644
--- a/lib/dml/parser.ml
+++ b/lib/dml/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let of_sexp sexp =
diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml
index 3900f73..5f820c8 100644
--- a/lib/drl/executor.ml
+++ b/lib/drl/executor.ml
@@ -2,9 +2,9 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
 
-    let parse_error error = condition "parse-error" ("message" |=| (of_string error))
-    let relation_not_found name = condition "relation-not-found" ("name" |=| (of_string name))
-    let unsupported_operator msg = condition "unsupported-operator" ("message" |=| (of_string msg))
+    let parse_error error = condition "parse-error" error empty
+    let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name))
+    let unsupported_operator msg = condition "unsupported-operator" msg empty
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/drl/parser.ml b/lib/drl/parser.ml
index df8e485..be1f1eb 100644
--- a/lib/drl/parser.ml
+++ b/lib/drl/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let of_sexp sexp =
diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml
index 7c23a28..084fb71 100644
--- a/lib/icl/executor.ml
+++ b/lib/icl/executor.ml
@@ -1,7 +1,7 @@
 module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
-    let multigroup_not_found name = condition "multigroup-not-found" ("name" |=| (of_string name))
+    let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name))
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml
index 49fa7e0..a4df914 100644
--- a/lib/icl/parser.ml
+++ b/lib/icl/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let of_sexp sexp =
diff --git a/lib/listener.ml b/lib/listener.ml
index 74b7a8e..ba61a50 100644
--- a/lib/listener.ml
+++ b/lib/listener.ml
@@ -13,15 +13,14 @@ functor
       open Condition
 
       let syntax_error msg =
-        condition "syntax-error"
-          ("message" |=| (of_string msg))
+        condition "syntax-error" msg empty
 
       let unrecognized_sublanguage tag =
-        condition "unrecognized-sublanguage"
+        condition "unrecognized-sublanguage" "Unrecognized sublanguage"
           ("tag" |=| (of_string tag))
 
       let malformed_expression expr =
-        condition "malformed-expression"
+        condition "malformed-expression" "Malformed expression"
           ("expression" |=| (of_sexp expr))
     end
 
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
index 1d28c36..4ba0983 100644
--- a/lib/management/branch.ml
+++ b/lib/management/branch.ml
@@ -15,7 +15,7 @@ let names_key = "branch_names"
 module Make (Storage : Physical.S) = struct
   module Error = struct
     open Condition
-    let branch_not_found name = condition "branch-not-found" ("name" |=| (of_string name))
+    let branch_not_found name = condition "branch-not-found" "Branch not found" ("name" |=| (of_string name))
   end
 
   let load_names storage =
diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml
index f115d97..b908302 100644
--- a/lib/management/multigroup.ml
+++ b/lib/management/multigroup.ml
@@ -13,6 +13,7 @@ class multigroup ~name:(init_name : Conventions.Name.t) =
     method relations = relations
     method timestamp = timestamp
 
+    (* TODO: a variant returning (Relation.relation, Condition.t) result *)
     method get_relation rel_name = BatMap.String.find_opt rel_name relations
     method get_relation_names = BatMap.String.fold (fun n _ acc -> n :: acc) relations []
     method has_relation rel_name = BatMap.String.mem rel_name relations
diff --git a/lib/management/physical.ml b/lib/management/physical.ml
index 3765cff..7c6f6b2 100644
--- a/lib/management/physical.ml
+++ b/lib/management/physical.ml
@@ -132,9 +132,9 @@ module MemoryBackend :
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
-    let already_in_transaction = condition "already-in-transaction" empty
-    let not_in_transaction = condition "not-in-transaction" empty
+    let parse_error msg = condition "parse-error" msg empty
+    let already_in_transaction = condition "already-in-transaction" "Already inside a transaction" empty
+    let not_in_transaction = condition "not-in-transaction" "Not inside a transaction" empty
   end
 
   let parse sexp =
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index d98127c..e62af28 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -22,8 +22,7 @@ module Make (Storage : Management.Physical.S) = struct
 
     (* TODO: more specific errors *)
     let storage_error message =
-      condition "storage-error"
-        ("message" |=| (of_string message))
+      condition "storage-error" message empty
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/nt.ml b/lib/nt.ml
index 0adf6d9..8622110 100644
--- a/lib/nt.ml
+++ b/lib/nt.ml
@@ -37,11 +37,11 @@ type plan_node =
 module Error = struct
   open Condition
   (* TODO: better error structure *)
-  let auth_failed msg = condition "auth-failed" ("message" |=| (of_string msg))
-  let handle_error msg = condition "handle-error" ("message" |=| (of_string msg))
-  let cursor_error msg = condition "cursor-error" ("message" |=| (of_string msg))
-  let not_supported msg = condition "not-supported" ("message" |=| (of_string msg))
-  let initialization_error = condition "initialization-error" empty
+  let auth_failed msg = condition "auth-failed" msg empty
+  let handle_error msg = condition "handle-error" msg empty
+  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
 end
 
 (* --------------------------------------------------------------------------
diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml
index 8ed4195..fcd4ec0 100644
--- a/lib/prl/executor.ml
+++ b/lib/prl/executor.ml
@@ -2,10 +2,10 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
-    let runtime_error msg = condition "runtime-error" ("message" |=| (of_string msg))
-    let unknown_plugin_symbol name = condition "unknown-plugin-symbol" ("name" |=| (of_string name))
-    let relation_not_found name = condition "relation-not-found" ("name" |=| (of_string name))
+    let parse_error msg = condition "parse-error" msg empty
+    let runtime_error msg = condition "runtime-error" msg empty
+    let unknown_plugin_symbol name = condition "unknown-plugin-symbol" "Unknown plugin" ("name" |=| (of_string name))
+    let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name))
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml
index 59cbceb..2567eea 100644
--- a/lib/prl/parser.ml
+++ b/lib/prl/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let of_sexp sexp =
diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml
index d69e866..a67f815 100644
--- a/lib/qualified_name.ml
+++ b/lib/qualified_name.ml
@@ -15,7 +15,8 @@ type t = { mg : string; name : string }
 
 module Error = struct
   open Condition
-  let unqualified_name name = condition "unqualified-name" ("name" |=| (of_string name))
+  let unqualified_name name = condition "unqualified-name" "A qualified name was expected, but an unqualified one was given"
+                                ("name" |=| (of_string name))
 end
 
 exception Unqualified of string
diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml
index 3785c4a..e40fde6 100644
--- a/lib/scl/executor.ml
+++ b/lib/scl/executor.ml
@@ -16,7 +16,7 @@ module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let cursor_error msg = condition "cursor-error" ("message" |=| (of_string msg))
+    let cursor_error msg = condition "cursor-error" msg empty
   end
 
   let ( let* ) = Result.bind
diff --git a/lib/scl/parser.ml b/lib/scl/parser.ml
index 86c3f99..53719ee 100644
--- a/lib/scl/parser.ml
+++ b/lib/scl/parser.ml
@@ -1,6 +1,6 @@
 module Error = struct
   open Condition
-  let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+  let parse_error msg = condition "parse-error" msg empty
 end
 
 let validate = function
diff --git a/lib/system.ml b/lib/system.ml
index 831cf74..56a5440 100644
--- a/lib/system.ml
+++ b/lib/system.ml
@@ -19,7 +19,7 @@ type registry = {
 
 module Error = struct
   open Condition
-  let unknown_backend component tag = condition "unknown-backend"
+  let unknown_backend component tag = condition "unknown-backend" "Unknown backend for component"
                                         ("component" |=| (of_string component) &
                                          "tag" |=| (of_string tag))
 end
diff --git a/lib/transport.ml b/lib/transport.ml
index 90393da..4ed9743 100644
--- a/lib/transport.ml
+++ b/lib/transport.ml
@@ -23,7 +23,7 @@ module TCP : TRANSPORT = struct
   module Error = struct
     open Condition
     (* TODO: more structure *)
-    let parse_error msg = condition "parse-error" ("message" |=| (of_string msg))
+    let parse_error msg = condition "parse-error" msg empty
   end
 
   let sockaddr_of_fields = function
diff --git a/lib/vcl/sublanguage.ml b/lib/vcl/sublanguage.ml
index b2734ca..4319eb8 100644
--- a/lib/vcl/sublanguage.ml
+++ b/lib/vcl/sublanguage.ml
@@ -1,7 +1,7 @@
 module Make (NT : Nt.S) = struct
   module Error = struct
     open Condition
-    let unrecognized_command expr = condition "unrecognized-command" ("expression" |=| (of_sexp expr))
+    let unrecognized_command expr = condition "unrecognized-command" "Unrecognized command" ("expression" |=| (of_sexp expr))
   end
 
   module Exec = Executor.Make (NT)