Enhance error position reporting, add error.on_error

CHANGES.md

@@ -3,6 +3,8 @@
 
 Added:
 * Added `time.string`.
+* Added `error.on_error` to report any error raised during the
+  script's execution. Enhanced reported error positions (#2712)
 
 Changed:
 * Send data in-memory in `http.{post,put}.file` when input data

src/Makefile

@@ -273,8 +273,8 @@ liquidsoap_sources += \
 	lang/profiler.ml lang/term.ml lang/value.ml \
 	lang/lang_encoder.ml $(lang_encoders) \
 	lang/environment.ml lang/typechecking.ml \
-	lang/evaluation.ml lang/error.ml \
-        lang/documentation.ml lang/lang_core.ml \
+	lang/documentation.ml lang/lang_core.ml \
+        lang/evaluation.ml lang/error.ml \
 	lang/lang_error.ml lang/lang_source.ml \
         lang/lang.ml lang/modules.ml \
 	lang/parser_helper.ml lang/parser.ml lang/lexer.ml \

src/builtins/builtins_bool.ml

@@ -48,9 +48,9 @@ let () =
     ]
     Lang.bool_t
     (fun p ->
-      match List.map (fun (_, x) -> Lang.to_bool_getter x) p with
-        | [a; b] -> Lang.bool (if a () then b () else false)
-        | _ -> assert false);
+      let f pos = Lang.to_bool_getter (Lang.assoc "" pos p) in
+      let a, b = (f 1, f 2) in
+      Lang.bool (if a () then b () else false));
   Lang.add_builtin "or" ~category:`Bool
     ~descr:"Return the disjunction of its arguments"
     [
@@ -59,9 +59,9 @@ let () =
     ]
     Lang.bool_t
     (fun p ->
-      match List.map (fun (_, x) -> Lang.to_bool_getter x) p with
-        | [a; b] -> Lang.bool (if a () then true else b ())
-        | _ -> assert false)
+      let f pos = Lang.to_bool_getter (Lang.assoc "" pos p) in
+      let a, b = (f 1, f 2) in
+      Lang.bool (if a () then true else b ()))
 
 let () =
   Lang.add_builtin "not" ~category:`Bool

src/builtins/builtins_ffmpeg_filters.ml

@@ -113,16 +113,9 @@ module Graph = Value.MkAbstract (struct
   let name = "ffmpeg.filter.graph"
   let descr _ = name
 
-  let to_json _ =
-    raise
-      Runtime_error.(
-        Runtime_error
-          {
-            kind = "json";
-            msg =
-              Printf.sprintf "Ffmpeg filter graph cannot be represented as json";
-            pos = [];
-          })
+  let to_json ~pos _ =
+    Runtime_error.raise ~pos
+      ~message:"Ffmpeg filter graph cannot be represented as json" "json"
 
   let compare = Stdlib.compare
 end)
@@ -136,15 +129,9 @@ module Audio = Value.MkAbstract (struct
   let name = "ffmpeg.filter.audio"
   let descr _ = name
 
-  let to_json _ =
-    raise
-      Runtime_error.(
-        Runtime_error
-          {
-            kind = "json";
-            msg = "Ffmpeg filter audio input cannot be represented as json";
-            pos = [];
-          })
+  let to_json ~pos _ =
+    Runtime_error.raise ~pos
+      ~message:"Ffmpeg filter audio input cannot be represented as json" "json"
 
   let compare = Stdlib.compare
 end)
@@ -158,15 +145,9 @@ module Video = Value.MkAbstract (struct
   let name = "ffmpeg.filter.video"
   let descr _ = name
 
-  let to_json _ =
-    raise
-      Runtime_error.(
-        Runtime_error
-          {
-            kind = "json";
-            msg = "Ffmpeg filter video input cannot be represented as json";
-            pos = [];
-          })
+  let to_json ~pos _ =
+    Runtime_error.raise ~pos
+      ~message:"Ffmpeg filter video input cannot be represented as json" "json"
 
   let compare = Stdlib.compare
 end)
@@ -414,7 +395,7 @@ let apply_filter ~args_parser ~filter ~sources_t p =
             (fun p ->
               let v = List.assoc "" p in
               if !input_set then
-                Runtime_error.error
+                Runtime_error.raise
                   ~pos:(match v.Value.pos with None -> [] | Some p -> [p])
                   ~message:"Filter input already set!" "ffmpeg.filter";
               let audio_inputs_c = List.length filter.io.inputs.audio in

src/builtins/builtins_files.ml

@@ -237,7 +237,7 @@ let () =
       let f = List.assoc_nth "" 1 p in
       let f () = ignore (Lang.apply f []) in
       let watch = !Configure.file_watcher in
-      let unwatch = watch [`Modify] fname f in
+      let unwatch = watch ~pos:(Lang.pos p) [`Modify] fname f in
       Lang.meth Lang.unit
         [
           ( "unwatch",
@@ -430,4 +430,4 @@ let () =
         Lang.string (Digest.to_hex (Digest.file file))
       else (
         let message = Printf.sprintf "The file %s does not exist." file in
-        Lang.raise_error ~message "file"))
+        Lang.raise_error ~pos:(Lang.pos p) ~message "file"))

src/builtins/builtins_http.ml

@@ -24,13 +24,6 @@ type request = Get | Post | Put | Head | Delete
 
 let request_with_body = [Get; Post; Put]
 
-let add_http_error kind =
-  Lang.add_builtin_base ~category:`Liquidsoap
-    ~descr:(Printf.sprintf "Base error for %s" kind)
-    (Printf.sprintf "%s.error" kind)
-    (Lang.error { Runtime_error.kind; msg = ""; pos = [] }).Lang.value
-    Lang.error_t
-
 let add_http_request ~stream_body ~descr ~request name =
   let name = Printf.sprintf "http.%s" name in
   let name = if stream_body then Printf.sprintf "%s.stream" name else name in
@@ -160,8 +153,8 @@ let add_http_request ~stream_body ~descr ~request name =
               | Delete -> `Delete
           in
           let ans =
-            Liqcurl.http_request ~follow_redirect:redirect ~timeout ~headers
-              ~url
+            Liqcurl.http_request ~pos:(Lang.pos p) ~follow_redirect:redirect
+              ~timeout ~headers ~url
               ~on_body_data:(fun s -> on_body_data (Some s))
               ~request ?http_version ()
           in
@@ -207,7 +200,6 @@ let add_http_request ~stream_body ~descr ~request name =
         ])
 
 let () =
-  add_http_error "http";
   List.iter
     (fun stream_body ->
       add_http_request ~descr:"Perform a full Http GET request." ~request:Get

src/builtins/builtins_json.ml

@@ -23,29 +23,24 @@
 let log_deprecated = Log.make ["deprecated"]
 let log = Log.make ["lang"; "json"]
 
-let rec json_of_value v : Json.t =
+let rec json_of_value ~pos v : Json.t =
   match v.Value.value with
     | Value.Null -> `Null
-    | Value.Ground g -> Term.Ground.to_json g
-    | Value.List l -> `Tuple (List.map json_of_value l)
-    | Value.Tuple l -> `Tuple (List.map json_of_value l)
+    | Value.Ground g -> Term.Ground.to_json ~pos g
+    | Value.List l -> `Tuple (List.map (json_of_value ~pos) l)
+    | Value.Tuple l -> `Tuple (List.map (json_of_value ~pos) l)
     | Value.Meth _ -> (
         let m, v = Value.split_meths v in
         match v.Value.value with
           | Value.Tuple [] ->
-              `Assoc (List.map (fun (l, v) -> (l, json_of_value v)) m)
-          | _ -> json_of_value v)
+              `Assoc (List.map (fun (l, v) -> (l, json_of_value ~pos v)) m)
+          | _ -> json_of_value ~pos v)
     | _ ->
-        raise
-          Runtime_error.(
-            Runtime_error
-              {
-                kind = "json";
-                msg =
-                  Printf.sprintf "Value %s cannot be represented as json"
-                    (Value.to_string v);
-                pos = (match v.Value.pos with Some p -> [p] | None -> []);
-              })
+        Runtime_error.raise ~pos
+          ~message:
+            (Printf.sprintf "Value %s cannot be represented as json"
+               (Value.to_string v))
+          "json"
 
 let rec type_of_json = function
   | `Assoc l ->
@@ -67,7 +62,9 @@ let rec json_of_typed_value ~ty v : Json.t =
     match (v.Value.value, _ty.Type.descr) with
       | Value.Null, Type.Nullable _ -> `Null
       | Value.Ground g, Type.Ground g' when Term.Ground.to_type g = g' ->
-          Term.Ground.to_json g
+          Term.Ground.to_json
+            ~pos:(match v.Value.pos with None -> [] | Some p -> [p])
+            g
       | Value.List l, Type.(List { t = ty; json_repr = `Tuple }) ->
           `Tuple (List.map (json_of_typed_value ~ty) l)
       | ( Value.List l,
@@ -103,24 +100,23 @@ let rec json_of_typed_value ~ty v : Json.t =
                      tm)
             | _ -> json_of_typed_value ~ty v)
       | _, Type.Var _ ->
-          let j = json_of_value v in
+          let j =
+            json_of_value
+              ~pos:(match ty.Type.pos with None -> [] | Some p -> [p])
+              v
+          in
           Typing.(_ty <: type_of_json j);
           j
       | _ -> assert false
   with
     | _ when nullable -> `Null
     | _ ->
-        raise
-          Runtime_error.(
-            Runtime_error
-              {
-                kind = "json";
-                msg =
-                  Printf.sprintf
-                    "Value %s of type %s cannot be represented as json"
-                    (Value.to_string v) (Type.to_string ty);
-                pos = (match v.Value.pos with Some p -> [p] | None -> []);
-              })
+        Runtime_error.raise
+          ~pos:(match v.Value.pos with Some p -> [p] | None -> [])
+          ~message:
+            (Printf.sprintf "Value %s of type %s cannot be represented as json"
+               (Value.to_string v) (Type.to_string ty))
+          "json"
 
 type json_ellipsis_base =
   [ `Assoc of (string * string option * json_ellipsis) list
@@ -259,38 +255,30 @@ let rec value_of_typed_json ~ty json =
 let value_of_typed_json ~ty json =
   try value_of_typed_json ~ty json with
     | Failed v ->
-        raise
-          Runtime_error.(
-            Runtime_error
-              {
-                kind = "json";
-                msg =
-                  Printf.sprintf
-                    "Parsing error: json value cannot be parsed as type %s"
-                    (string_of_json_ellipsis v);
-                pos = (match ty.Type.pos with Some p -> [p] | None -> []);
-              })
+        Runtime_error.raise
+          ~pos:(match ty.Type.pos with Some p -> [p] | None -> [])
+          ~message:
+            (Printf.sprintf
+               "Parsing error: json value cannot be parsed as type %s"
+               (string_of_json_ellipsis v))
+          "json"
     | _ ->
-        raise
-          Runtime_error.(
-            Runtime_error
-              {
-                kind = "json";
-                msg =
-                  Printf.sprintf
-                    "Parsing error: json value cannot be parsed as type %s"
-                    (Type.to_string ty);
-                pos = (match ty.Type.pos with Some p -> [p] | None -> []);
-              })
+        Runtime_error.raise
+          ~pos:(match ty.Type.pos with Some p -> [p] | None -> [])
+          ~message:
+            (Printf.sprintf
+               "Parsing error: json value cannot be parsed as type %s"
+               (Type.to_string ty))
+          "json"
 
 module JsonSpecs = struct
   type content = (string, Lang.value) Hashtbl.t
 
   let name = "json"
   let descr _ = "json"
 
-  let to_json v =
-    `Assoc (Hashtbl.fold (fun k v l -> (k, json_of_value v) :: l) v [])
+  let to_json ~pos v =
+    `Assoc (Hashtbl.fold (fun k v l -> (k, json_of_value ~pos v) :: l) v [])
 
   let compare = Stdlib.compare
 end
@@ -346,8 +334,9 @@ let () =
             (fun p ->
               let compact = Lang.to_bool (List.assoc "compact" p) in
               let json5 = Lang.to_bool (List.assoc "json5" p) in
-              Lang.string (Json.to_string ~compact ~json5 (JsonSpecs.to_json v)))
-      );
+              Lang.string
+                (Json.to_string ~compact ~json5
+                   (JsonSpecs.to_json ~pos:(Lang.pos p) v))) );
     ]
   in
   let t =
@@ -386,7 +375,7 @@ let () =
         try
           let json =
             match ty.Type.descr with
-              | Type.Var _ -> json_of_value v
+              | Type.Var _ -> json_of_value ~pos:(Lang.pos p) v
               | _ -> json_of_typed_value ~ty v
           in
           Json.to_string ~compact ~json5 json
@@ -413,23 +402,16 @@ let () =
       try
         let json = Json.from_string ~json5 s in
         value_of_typed_json ~ty json
-      with exn ->
+      with exn -> (
         let bt = Printexc.get_raw_backtrace () in
-        let exn =
-          match exn with
-            | Runtime_error.Runtime_error _ -> exn
-            | _ ->
-                Runtime_error.(
-                  Runtime_error
-                    {
-                      kind = "json";
-                      msg =
-                        Printf.sprintf "Parse error: %s"
-                          (Printexc.to_string exn);
-                      pos = [];
-                    })
-        in
-        Printexc.raise_with_backtrace exn bt)
+        match exn with
+          | Runtime_error.Runtime_error _ ->
+              Printexc.raise_with_backtrace exn bt
+          | _ ->
+              Runtime_error.raise ~pos:(Lang.pos p)
+                ~message:
+                  (Printf.sprintf "Parse error: %s" (Printexc.to_string exn))
+                "json"))
 
 exception DeprecatedFailed
 

src/builtins/builtins_lang.ml

@@ -582,12 +582,12 @@ let () =
       let f = Lang.to_string (List.assoc "" p) in
       let f = Utils.home_unrelate f in
       if not (Sys.file_exists f) then
-        Runtime_error.error
+        Runtime_error.raise ~pos:(Lang.pos p)
           ~message:
             (Printf.sprintf "File %s does not exist!" (Utils.quote_string f))
           "playlist";
       if Sys.is_directory f then
-        Runtime_error.error
+        Runtime_error.raise ~pos:(Lang.pos p)
           ~message:
             (Printf.sprintf
                "File %s is a directory! A regular file was expected."