From b53e5431c9f199e70ad8bab45d24e500420af161 Mon Sep 17 00:00:00 2001 From: Romain Beauxis Date: Mon, 16 Jan 2023 12:54:22 -0600 Subject: [PATCH 1/3] Add suport for yaml parsing/rendering. --- dune-project | 1 + liquidsoap.opam | 1 + src/config/yaml_option.disabled.ml | 1 + src/config/yaml_option.enabled.ml | 1 + src/core/builtins/builtins_yaml.ml | 94 ++++++++++++++++++++++++++++++ src/core/dune | 14 +++++ src/lang/builtins_yaml.ml | 51 ++++++++++++++++ src/lang/dune | 1 + src/lang/lexer.ml | 1 + src/lang/parser_helper.ml | 14 ++++- src/runtime/build_config.ml | 1 + tests/language/dune.inc | 13 +++++ tests/language/yaml.liq | 38 ++++++++++++ 13 files changed, 230 insertions(+), 1 deletion(-) create mode 120000 src/config/yaml_option.disabled.ml create mode 120000 src/config/yaml_option.enabled.ml create mode 100644 src/core/builtins/builtins_yaml.ml create mode 100644 src/lang/builtins_yaml.ml create mode 100644 tests/language/yaml.liq diff --git a/dune-project b/dune-project index 4cd69f2157..6052b9d093 100644 --- a/dune-project +++ b/dune-project @@ -78,6 +78,7 @@ tsdl-image tsdl-ttf vorbis + yaml xmlplaylist) (conflicts (alsa (< 0.3.0)) diff --git a/liquidsoap.opam b/liquidsoap.opam index 3510b34380..638a0ac55e 100644 --- a/liquidsoap.opam +++ b/liquidsoap.opam @@ -81,6 +81,7 @@ depopts: [ "tsdl-image" "tsdl-ttf" "vorbis" + "yaml" "xmlplaylist" ] conflicts: [ diff --git a/src/config/yaml_option.disabled.ml b/src/config/yaml_option.disabled.ml new file mode 120000 index 0000000000..370c3e56d3 --- /dev/null +++ b/src/config/yaml_option.disabled.ml @@ -0,0 +1 @@ +noop.disabled.ml \ No newline at end of file diff --git a/src/config/yaml_option.enabled.ml b/src/config/yaml_option.enabled.ml new file mode 120000 index 0000000000..34bd7cbe43 --- /dev/null +++ b/src/config/yaml_option.enabled.ml @@ -0,0 +1 @@ +noop.enabled.ml \ No newline at end of file diff --git a/src/core/builtins/builtins_yaml.ml b/src/core/builtins/builtins_yaml.ml new file mode 100644 index 0000000000..8c9ae70395 --- /dev/null +++ b/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") diff --git a/src/core/dune b/src/core/dune index 4e48c321a0..eb742716e6 100644 --- a/src/core/dune +++ b/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 diff --git a/src/lang/builtins_yaml.ml b/src/lang/builtins_yaml.ml new file mode 100644 index 0000000000..c268b9a52f --- /dev/null +++ b/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")) diff --git a/src/lang/dune b/src/lang/dune index dc66d9abc6..fd4fab27ce 100644 --- a/src/lang/dune +++ b/src/lang/dune @@ -93,6 +93,7 @@ builtins_profiler builtins_regexp builtins_string + builtins_yaml builtins_ref console doc diff --git a/src/lang/lexer.ml b/src/lang/lexer.ml index ac4908592e..088afbff8d 100644 --- a/src/lang/lexer.ml +++ b/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 diff --git a/src/lang/parser_helper.ml b/src/lang/parser_helper.ml index fcc0a3d331..c97e9204e0 100644 --- a/src/lang/parser_helper.ml +++ b/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 diff --git a/src/runtime/build_config.ml b/src/runtime/build_config.ml index 9f29bd1630..d4615fffb4 100644 --- a/src/runtime/build_config.ml +++ b/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 diff --git a/tests/language/dune.inc b/tests/language/dune.inc index 37ef753d45..e03bc26553 100644 --- a/tests/language/dune.inc +++ b/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) diff --git a/tests/language/yaml.liq b/tests/language/yaml.liq new file mode 100644 index 0000000000..e1381b3fc8 --- /dev/null +++ b/tests/language/yaml.liq @@ -0,0 +1,38 @@ +def f () = + j = json() + j.add("foo", 1) + j.add("bla", "bar") + j.add("baz", 3.14) + j.add("key_with_methods", "value".{method = 123}) + j.add("record", { a = 1, b = "ert"}) + j.remove("foo") + j = yaml.stringify(j) + test.equals(j, 'record: + b: ert + a: 1 +key_with_methods: value +bla: bar +baz: 3.14 +') + + let yaml.parse (x : { + bla: string, + baz: float, + key_with_methods: string, + record: { a: float, b: string}, + }) = j + + test.equals(x, { + record = { + b = "ert", + a = 1.0 + }, + key_with_methods = "value", + bla = "bar", + baz = 3.14 + }); + + test.pass() +end + +test.check(f) From 6718383e3b757930695842bbefe3cfe7dccd3f39 Mon Sep 17 00:00:00 2001 From: Romain Beauxis Date: Mon, 16 Jan 2023 16:14:58 -0600 Subject: [PATCH 2/3] Install yaml. --- .github/scripts/build-posix.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/scripts/build-posix.sh b/.github/scripts/build-posix.sh index dcfff4ee27..4e129a17db 100755 --- a/.github/scripts/build-posix.sh +++ b/.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. From e86e32f3b498214e8c558cb34ccc581731e2e93a Mon Sep 17 00:00:00 2001 From: Romain Beauxis Date: Tue, 24 Jan 2023 22:59:03 -0600 Subject: [PATCH 3/3] Add doc. --- doc/content/yaml.md | 29 +++++++++++++++++++++++++++++ doc/dune.inc | 23 ++++++++++++++++++++++- 2 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 doc/content/yaml.md diff --git a/doc/content/yaml.md b/doc/content/yaml.md new file mode 100644 index 0000000000..6e2c6c674f --- /dev/null +++ b/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. diff --git a/doc/dune.inc b/doc/dune.inc index e8672e436c..fa6326743d 100644 --- a/doc/dune.inc +++ b/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)))