Add support for yaml parsing/rendering. (#2855)

.github/scripts/build-posix.sh

@@ -35,7 +35,7 @@ if [ -z "${LIQ_BUILD_MIN}" ]; then
   git clone https://github.com/savonet/ocaml-posix.git
   cd ocaml-posix && opam install -y . && cd ..
   # See: https://github.com/whitequark/ocaml-inotify/pull/20
-  opam install -y uri inotify.2.3
+  opam install -y uri yaml inotify.2.3
 fi
 
 # TODO: Add those to docker CI images.

doc/content/yaml.md

@@ -0,0 +1,29 @@
+## Importing/exporting YAML values
+
+Support for YAML parsing and rendering was first added in liquidsoap `2.2.0`. This support follows the same pattern as [JSON parsing/rendering](json.html) but using
+yaml-based syntax, i.e.:
+
+```liauidsoap
+let yaml.parse ({
+  name,
+  version,
+  scripts,
+} : {
+  name: string,
+  version: string,
+  scripts: {
+    test: string?
+  }?
+}) = file.contents("/path/to/file.yaml")
+```
+
+and
+
+```liquidsoap
+r = {artist = "Bla", title = "Blo"}
+print(yaml.stringify(r))
+```
+
+The only major difference being that, in YAML, all numbers are parsed and rendered as _floats_.
+
+Please refer to the [JSON parsing and rendering](json.html) documentation for more details.

doc/dune.inc

@@ -1469,6 +1469,26 @@
     (ignore-outputs
       (run pandoc --syntax-definition=liquidsoap.xml --highlight=pygments %{md} --metadata pagetitle=video --template=template.html -o %{target}))))
 
+(rule
+  (alias doc)
+  (enabled_if (not %{bin-available:pandoc}))
+  (deps (:no_pandoc no-pandoc))
+  (target yaml.html)
+  (action (run cp %{no_pandoc} %{target})))
+
+(rule
+  (alias doc)
+  (enabled_if %{bin-available:pandoc})
+  (deps
+    liquidsoap.xml
+    language.dtd
+    template.html
+    (:md content/yaml.md))
+  (target yaml.html)
+  (action
+    (ignore-outputs
+      (run pandoc --syntax-definition=liquidsoap.xml --highlight=pygments %{md} --metadata pagetitle=yaml --template=template.html -o %{target}))))
+
 (install
  (section doc)
  (package liquidsoap)
@@ -1563,4 +1583,5 @@
 (split-cue.html as html/split-cue.html)
 (stream_content.html as html/stream_content.html)
 (video-static.html as html/video-static.html)
-(video.html as html/video.html)))
+(video.html as html/video.html)
+(yaml.html as html/yaml.html)))

dune-project

@@ -78,6 +78,7 @@
     tsdl-image
     tsdl-ttf
     vorbis
+    yaml
     xmlplaylist)
  (conflicts
     (alsa (< 0.3.0))

liquidsoap.opam

@@ -81,6 +81,7 @@ depopts: [
   "tsdl-image"
   "tsdl-ttf"
   "vorbis"
+  "yaml"
   "xmlplaylist"
 ]
 conflicts: [

src/config/yaml_option.disabled.ml

@@ -0,0 +1 @@
+noop.disabled.ml

src/config/yaml_option.enabled.ml

@@ -0,0 +1 @@
+noop.enabled.ml

src/core/builtins/builtins_yaml.ml

@@ -0,0 +1,94 @@
+(*****************************************************************************
+
+  Liquidsoap, a programmable audio stream generator.
+  Copyright 2003-2023 Savonet team
+
+  This program is free software; you can redistribute it and/or modify
+  it under the terms of the GNU General Public License as published by
+  the Free Software Foundation; either version 2 of the License, or
+  (at your option) any later version.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+  GNU General Public License for more details, fully stated in the COPYING
+  file at the root of the liquidsoap distribution.
+
+  You should have received a copy of the GNU General Public License
+  along with this program; if not, write to the Free Software
+  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301  USA
+
+ *****************************************************************************)
+
+let () = Atomic.set Liquidsoap_lang.Builtins_yaml.yaml_parser Yaml.of_string_exn
+let yaml = Lang.add_module "yaml"
+
+let rec yaml_of_json = function
+  | `Assoc l -> `O (List.map (fun (lbl, v) -> (lbl, yaml_of_json v)) l)
+  | `Tuple l -> `A (List.map yaml_of_json l)
+  | `String s -> `String s
+  | `Bool b -> `Bool b
+  | `Float f -> `Float f
+  | `Int i -> `Float (float i)
+  | `Null -> `Null
+
+let scalar_style pos = function
+  | "any" -> `Any
+  | "plain" -> `Plain
+  | "single_quoted" -> `Single_quoted
+  | "double_quoted" -> `Double_quoted
+  | "literal" -> `Literal
+  | "folded" -> `Folded
+  | v ->
+      Runtime_error.raise
+        ~message:(Printf.sprintf "Invalid scalar style: %s" v)
+        ~pos "yaml"
+
+let layout_style pos = function
+  | "any" -> `Any
+  | "block" -> `Block
+  | "flow" -> `Flow
+  | v ->
+      Runtime_error.raise
+        ~message:(Printf.sprintf "Invalid layout style: %s" v)
+        ~pos "yaml"
+
+let _ =
+  Lang.add_builtin ~base:yaml "stringify" ~category:`String
+    ~descr:
+      "Convert a value to YAML. If the value cannot be represented as YAML \
+       (for instance a function), a `error.yaml` exception is raised."
+    [
+      ( "scalar_style",
+        Lang.string_t,
+        Some (Lang.string "any"),
+        Some
+          "Scalar style. One of: \"any\", \"plain\", \"single_quoted\", \
+           \"double_quoted\", \"literal\" or \"folded\"." );
+      ( "layout_style",
+        Lang.string_t,
+        Some (Lang.string "any"),
+        Some "Layout style. One of: \"any\", \"block\" or \"flow\"." );
+      ("", Lang.univ_t (), None, None);
+    ]
+    Lang.string_t
+    (fun p ->
+      let pos = Lang.pos p in
+      let v = List.assoc "" p in
+      let scalar_style =
+        scalar_style pos (Lang.to_string (List.assoc "scalar_style" p))
+      in
+      let layout_style =
+        layout_style pos (Lang.to_string (List.assoc "layout_style" p))
+      in
+      try
+        let json = Liquidsoap_lang.Builtins_json.json_of_value v in
+        Lang.string
+          (Yaml.to_string_exn ~encoding:`Utf8 ~scalar_style ~layout_style
+             (yaml_of_json json))
+      with _ ->
+        Runtime_error.raise
+          ~message:
+            (Printf.sprintf "Value %s cannot be represented as YAML"
+               (Value.to_string v))
+          ~pos "yaml")

src/core/dune

@@ -680,6 +680,14 @@
  (optional)
  (modules liq_vorbis_decoder vorbis_encoder vorbisduration))
 
+(library
+ (name liquidsoap_yaml)
+ (libraries yaml liquidsoap_core)
+ (library_flags -linkall)
+ (wrapped false)
+ (optional)
+ (modules builtins_yaml))
+
 (library
  (name liquidsoap_xmlplaylist)
  (libraries xmlplaylist liquidsoap_core)
@@ -745,6 +753,7 @@
   theora_option
   vorbis_option
   winsvc_option
+  yaml_option
   xmlplaylist_option)
  (libraries
   liquidsoap_core
@@ -983,6 +992,11 @@
    from
    (winsvc -> winsvc_option.enabled.ml)
    (-> winsvc_option.disabled.ml))
+  (select
+   yaml_option.ml
+   from
+   (liquidsoap_yaml -> yaml_option.enabled.ml)
+   (-> yaml_option.disabled.ml))
   (select
    xmlplaylist_option.ml
    from

src/lang/builtins_yaml.ml

@@ -0,0 +1,51 @@
+type yaml =
+  [ `Null
+  | `Bool of bool
+  | `Float of float
+  | `String of string
+  | `A of yaml list
+  | `O of (string * yaml) list ]
+
+let yaml_parser : (string -> yaml) Atomic.t =
+  Atomic.make (fun _ ->
+      Runtime_error.raise
+        ~message:
+          "YAML support not enabled! Please re-compile liquidsoap with the \
+           `yaml` module to enable YAML parsing and rendering."
+        ~pos:[] "not_found")
+
+let rec json_of_yaml = function
+  | `O l -> `Assoc (List.map (fun (lbl, v) -> (lbl, json_of_yaml v)) l)
+  | `A l -> `Tuple (List.map json_of_yaml l)
+  | `String s -> `String s
+  | `Bool b -> `Bool b
+  | `Float f -> `Float f
+  | `Null -> `Null
+
+let _ =
+  Lang.add_builtin "_internal_yaml_parser_" ~category:`String ~flags:[`Hidden]
+    ~descr:"Internal yaml parser"
+    [
+      ("type", Value.RuntimeType.t, None, Some "Runtime type");
+      ("", Lang.string_t, None, None);
+    ]
+    (Lang.univ_t ())
+    (fun p ->
+      let s = Lang.to_string (List.assoc "" p) in
+      let ty = Value.RuntimeType.of_value (List.assoc "type" p) in
+      let scheme = Typing.generalize ~level:(-1) ty in
+      let ty = Typing.instantiate ~level:(-1) scheme in
+      let parser = Atomic.get yaml_parser in
+      try
+        let yaml = parser s in
+        Builtins_json.value_of_typed_json ~ty (json_of_yaml yaml)
+      with exn -> (
+        let bt = Printexc.get_raw_backtrace () in
+        match exn with
+          | _ ->
+              Runtime_error.raise ~bt ~pos:(Lang.pos p)
+                ~message:
+                  (Printf.sprintf
+                     "Parse error: yaml value cannot be parsed as type: %s"
+                     (Type.to_string ty))
+                "yaml"))

src/lang/dune

@@ -93,6 +93,7 @@
   builtins_profiler
   builtins_regexp
   builtins_string
+  builtins_yaml
   builtins_ref
   console
   doc

src/lang/lexer.ml

@@ -201,6 +201,7 @@ let rec token lexbuf =
     | "let", Plus skipped, "json.parse", Star skipped, '[' ->
         LETLBRA `Json_parse
     | "let", Plus skipped, "json.parse", Plus skipped -> LET `Json_parse
+    | "let", Plus skipped, "yaml.parse", Plus skipped -> LET `Yaml_parse
     | "let" -> LET `None
     | "fun" -> FUN
     | '=' -> GETS

src/lang/parser_helper.ml

@@ -28,13 +28,14 @@ open Ground
 type arglist = (string * string * Type.t * Term.t option) list
 
 type lexer_let_decoration =
-  [ `None | `Recursive | `Replaces | `Eval | `Json_parse ]
+  [ `None | `Recursive | `Replaces | `Eval | `Json_parse | `Yaml_parse ]
 
 type let_decoration =
   [ `None
   | `Recursive
   | `Replaces
   | `Eval
+  | `Yaml_parse
   | `Json_parse of (string * Term.t) list ]
 
 type app_list_elem = (string * Term.t) list
@@ -71,6 +72,7 @@ type meth_ty_opt = {
 
 let let_decoration_of_lexer_let_decoration = function
   | `Json_parse -> `Json_parse []
+  | `Yaml_parse -> `Yaml_parse
   | `Eval -> `Eval
   | `Recursive -> `Recursive
   | `None -> `None
@@ -81,6 +83,7 @@ let string_of_let_decoration = function
   | `Recursive -> "rec"
   | `Replaces -> "replaces"
   | `Eval -> "eval"
+  | `Yaml_parse -> "yaml.parse"
   | `Json_parse _ -> "json.parse"
 
 let args_of_json_parse ~pos = function
@@ -376,6 +379,14 @@ let mk_let_json_parse ~pos (args, pat, def, cast) body =
   let def = mk ~pos (Cast (def, ty)) in
   mk ~pos (Let { doc = None; replace = false; pat; gen = []; def; body })
 
+let mk_let_yaml_parse ~pos (pat, def, cast) body =
+  let ty = match cast with Some ty -> ty | None -> Type.var ~pos () in
+  let tty = Value.RuntimeType.to_term ty in
+  let parser = mk ~pos (Var "_internal_yaml_parser_") in
+  let def = mk ~pos (App (parser, [("type", tty); ("", def)])) in
+  let def = mk ~pos (Cast (def, ty)) in
+  mk ~pos (Let { doc = None; replace = false; pat; gen = []; def; body })
+
 let mk_rec_fun ~pos pat args body =
   let name =
     match pat with
@@ -419,6 +430,7 @@ let mk_let ~pos (doc, decoration, pat, arglist, def, cast) body =
     | None, `Eval -> mk_eval ~pos (doc, pat, def, body, cast)
     | None, `Json_parse args ->
         mk_let_json_parse ~pos (args, pat, def, cast) body
+    | None, `Yaml_parse -> mk_let_yaml_parse ~pos (pat, def, cast) body
     | Some _, v ->
         raise
           (Parse_error

src/runtime/build_config.ml

@@ -106,6 +106,7 @@ let build_config =
    - ssl               : %{Ssl_option.detected}
    - posix-time2       : %{Posix_time_option.detected}
    - windows service   : %{Winsvc_option.detected}
+   - YAML support      : %{Yaml_option.detected}
    - XML playlists     : %{Xmlplaylist_option.detected}
 
  * Monitoring

tests/language/dune.inc

@@ -181,6 +181,19 @@
   (:run_test ../run_test.exe))
  (action (run %{run_test} stdlib.liq liquidsoap %{test_liq} stdlib.liq)))
 
+(rule
+ (alias runtest)
+ (package liquidsoap)
+ (deps
+  yaml.liq
+  ../media/all_media_files
+  ../../src/bin/liquidsoap.exe
+  (source_tree ../../src/libs)
+  (:stdlib ../../src/libs/stdlib.liq)
+  (:test_liq ../test.liq)
+  (:run_test ../run_test.exe))
+ (action (run %{run_test} yaml.liq liquidsoap %{test_liq} yaml.liq)))
+
 (rule
  (alias runtest)
  (package liquidsoap)