Dynamic source tracks.

src/core/dune

@@ -233,6 +233,7 @@
   theora_format
   time_warp
   track
+  source_tracks
   track_map
   tutils
   type

src/core/hooks_implementations.ml

@@ -18,6 +18,9 @@ let eval_check ~env:_ ~tm v =
       let ty = Type.fresh (deep_demeth tm.Term.t) in
       Typing.(Lang_source.source_t ~methods:false s#frame_type <: ty);
       s#content_type_computation_allowed))
+  else if Source_tracks.is_value v then (
+    let s = Source_tracks.source v in
+    Typing.(s#frame_type <: tm.Term.t))
   else if Track.is_value v then (
     let field, source = Lang_source.to_track v in
     if not source#has_content_type then (

src/core/lang_source.ml

@@ -361,17 +361,6 @@ let source_tracks_t frame_t =
     ([], Format_type.track_marks)
     (Type.meth "metadata" ([], Format_type.metadata) frame_t)
 
-let source_tracks s =
-  meth unit
-    (( Frame.Fields.string_of_field Frame.Fields.metadata,
-       Track.to_value (Frame.Fields.metadata, s) )
-    :: ( Frame.Fields.string_of_field Frame.Fields.track_marks,
-         Track.to_value (Frame.Fields.track_marks, s) )
-    :: List.map
-         (fun (field, _) ->
-           (Frame.Fields.string_of_field field, Track.to_value (field, s)))
-         (Frame.Fields.bindings s#content_type))
-
 let source_methods ~base s =
   meth base (List.map (fun (name, _, _, fn) -> (name, fn s)) source_methods)
 

src/core/operators/muxer.ml

@@ -20,30 +20,22 @@
 
  *****************************************************************************)
 
-type field = {
-  target_field : Frame.field;
-  source_field : Frame.field;
-  processor : Content.data -> Content.data;
-}
-
+type field = { target_field : Frame.field; source_field : Frame.field }
 type track = { mutable fields : field list; source : Source.source }
 
-class muxer tracks =
+class muxer ~pos ~base tracks =
   let sources =
     List.fold_left
       (fun sources { source } ->
         if List.memq source sources then sources else source :: sources)
-      [] tracks
+      (match base with Some s -> [Source_tracks.source s] | None -> [])
+      tracks
   in
   let fallible = List.exists (fun s -> s#fallible) sources in
   let self_sync = Clock_base.self_sync sources in
   object (self)
     (* Pass duplicated list to operator to make sure caching is properly enabled. *)
-    inherit
-      Source.operator
-        ~name:"source"
-        (List.map (fun { source } -> source) tracks)
-
+    inherit Source.operator ~name:"source" sources
     method self_sync = self_sync ~source:self ()
     method fallible = fallible
     method abort_track = List.iter (fun s -> s#abort_track) sources
@@ -76,6 +68,66 @@ class muxer tracks =
         (-1)
         (List.filter (fun (s : Source.source) -> s#is_ready) sources)
 
+    val mutable muxed_tracks = None
+
+    method private tracks =
+      match muxed_tracks with
+        | Some s -> s
+        | None ->
+            let base =
+              match base with
+                | Some source_tracks ->
+                    let fields =
+                      List.map
+                        (fun source_field ->
+                          { source_field; target_field = source_field })
+                        (Source_tracks.fields source_tracks)
+                    in
+                    [{ source = Source_tracks.source source_tracks; fields }]
+                | None -> []
+            in
+            let tracks =
+              match
+                ( base,
+                  List.partition
+                    (fun { source = s } ->
+                      List.exists (fun { source = s' } -> s == s') base)
+                    tracks )
+              with
+                | _, ([], _) -> base @ tracks
+                | [{ fields = f }], ([({ fields = f' } as p)], tracks) ->
+                    {
+                      p with
+                      fields =
+                        f'
+                        @ List.filter
+                            (fun { target_field = t } ->
+                              List.exists
+                                (fun { target_field = t' } -> t = t')
+                                f')
+                            f;
+                    }
+                    :: tracks
+                | _ -> assert false
+            in
+            if
+              List.for_all
+                (fun { fields } ->
+                  List.for_all
+                    (fun { target_field } ->
+                      target_field = Frame.Fields.metadata
+                      || target_field = Frame.Fields.track_marks)
+                    fields)
+                tracks
+            then
+              Runtime_error.raise ~pos
+                ~message:
+                  "source muxer needs at least one track with content that is \
+                   not metadata or track_marks!"
+                "invalid";
+            muxed_tracks <- Some tracks;
+            tracks
+
     method generate_frame =
       let length = Lazy.force Frame.size in
       let pos, frame =
@@ -84,49 +136,39 @@ class muxer tracks =
             let buf = source#get_frame in
             ( min pos (Frame.position buf),
               List.fold_left
-                (fun frame { source_field; target_field; processor } ->
-                  let c = processor (Frame.get buf source_field) in
+                (fun frame { source_field; target_field } ->
+                  let c = Frame.get buf source_field in
                   Frame.set frame target_field c)
                 frame fields ))
           (length, Frame.create ~length Frame.Fields.empty)
-          tracks
+          self#tracks
       in
       Frame.slice frame pos
   end
 
 let muxer_operator p =
-  let tracks = List.assoc "" p in
-  let processor c = c in
+  let base, tracks =
+    match List.assoc "" p with
+      | Liquidsoap_lang.Value.Custom { methods } as v
+        when Source_tracks.is_value v ->
+          (Some v, methods)
+      | v -> (None, Liquidsoap_lang.Value.methods v)
+  in
   let tracks =
     List.fold_left
       (fun tracks (label, t) ->
         let source_field, s = Lang.to_track t in
         let target_field = Frame.Fields.register label in
-        let field = { source_field; target_field; processor } in
+        let field = { source_field; target_field } in
         match List.find_opt (fun { source } -> source == s) tracks with
           | Some track ->
               track.fields <- field :: track.fields;
               tracks
           | None -> { source = s; fields = [field] } :: tracks)
       []
-      (fst (Lang.split_meths tracks))
+      (Liquidsoap_lang.Methods.bindings tracks)
   in
-  if
-    List.for_all
-      (fun { fields } ->
-        List.for_all
-          (fun { target_field } ->
-            target_field = Frame.Fields.metadata
-            || target_field = Frame.Fields.track_marks)
-          fields)
-      tracks
-  then
-    Runtime_error.raise ~pos:(Lang.pos p)
-      ~message:
-        "source muxer needs at least one track with content that is not \
-         metadata or track_marks!"
-      "invalid";
-  let s = new muxer tracks in
+  let s = new muxer ~pos:(try Lang.pos p with _ -> []) ~base tracks in
   let target_fields =
     List.fold_left
       (fun target_fields { source; fields } ->
@@ -151,7 +193,13 @@ let muxer_operator p =
         target_fields)
       Frame.Fields.empty tracks
   in
-  Typing.(s#frame_type <: Lang.frame_t (Lang.univ_t ()) target_fields);
+  Typing.(
+    s#frame_type
+    <: Lang.frame_t
+         (match base with
+           | Some s -> (Source_tracks.source s)#frame_type
+           | None -> Lang.univ_t ())
+         target_fields);
   s
 
 let source =
@@ -199,6 +247,7 @@ let _ =
         Type.filter_meths return_t (fun { Type.meth } ->
             meth <> "metadata" && meth <> "track_marks")
       in
-      let s = Lang.to_source (List.assoc "" env) in
+      let source_val = List.assoc "" env in
+      let s = Lang.to_source source_val in
       Typing.(s#frame_type <: return_t);
-      Lang_source.source_tracks s)
+      Source_tracks.to_value s)

src/core/source_tracks.ml

@@ -0,0 +1,68 @@
+(*****************************************************************************
+
+  Liquidsoap, a programmable stream generator.
+  Copyright 2003-2024 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
+
+ *****************************************************************************)
+
+include Liquidsoap_lang.Lang_core.MkCustom (struct
+  type content = Source.source
+
+  let name = "source.tracks"
+  let to_string s = Printf.sprintf "source.tracks(source=%s)" s#id
+
+  let to_json ~pos _ =
+    Runtime_error.raise ~pos
+      ~message:"Source tracks cannot be represented as json" "json"
+
+  let compare s1 s2 = Stdlib.compare s1#id s2#id
+end)
+
+let to_value ?pos s =
+  match to_value ?pos s with
+    | Liquidsoap_lang.Value.Custom p ->
+        Liquidsoap_lang.Value.Custom
+          {
+            p with
+            dynamic_methods =
+              Some
+                {
+                  hidden_methods = [];
+                  methods =
+                    (fun v ->
+                      Some (Track.to_value (Frame.Fields.register v, s)));
+                };
+          }
+    | _ -> assert false
+
+let source = of_value
+
+let fields = function
+  | Liquidsoap_lang.Value.Custom { dynamic_methods = Some { hidden_methods } }
+    as v
+    when is_value v ->
+      let source = of_value v in
+      let fields =
+        Frame.Fields.metadata :: Frame.Fields.track_marks
+        :: List.map fst (Frame.Fields.bindings source#content_type)
+      in
+      List.filter
+        (fun field ->
+          not (List.mem (Frame.Fields.string_of_field field) hidden_methods))
+        fields
+  | _ -> assert false

src/core/source_tracks.mli

@@ -0,0 +1,28 @@
+(*****************************************************************************
+
+  Liquidsoap, a programmable stream generator.
+  Copyright 2003-2024 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
+
+ *****************************************************************************)
+
+type content = Source.source
+
+val to_value : ?pos:Pos.t -> content -> Value.t
+val source : Value.t -> content
+val is_value : Value.t -> bool
+val fields : Value.t -> Frame.Fields.field list

src/lang/evaluation.ml

@@ -180,16 +180,41 @@ and eval_base_term ~eval_check (env : Env.t) tm =
     | `List l -> mk (`List (List.map (eval ~eval_check env) l))
     | `Tuple l -> mk (`Tuple (List.map (fun a -> eval ~eval_check env a) l))
     | `Null -> mk `Null
-    | `Hide (tm, methods) ->
+    | `Hide (tm, methods) -> (
         let v = eval ~eval_check env tm in
-        Value.map_methods v
-          (Methods.filter (fun n _ -> not (List.mem n methods)))
+        let v =
+          Value.map_methods v
+            (Methods.filter (fun n _ -> not (List.mem n methods)))
+        in
+        match v with
+          | Value.Custom ({ dynamic_methods = Some d } as p) ->
+              Value.Custom
+                {
+                  p with
+                  dynamic_methods =
+                    Some
+                      {
+                        d with
+                        hidden_methods =
+                          List.sort_uniq Stdlib.compare
+                            (methods @ d.hidden_methods);
+                      };
+                }
+          | v -> v)
     | `Cast { cast = e } -> Value.set_pos (eval ~eval_check env e) tm.t.Type.pos
     | `Invoke { invoked = t; invoke_default; meth } -> (
         let v = eval ~eval_check env t in
-        match
-          (Value.Methods.find_opt meth (Value.methods v), invoke_default)
-        with
+        let invoked_value =
+          match (Value.Methods.find_opt meth (Value.methods v), v) with
+            | Some v, _ -> Some v
+            | ( None,
+                Value.Custom
+                  { dynamic_methods = Some { hidden_methods; methods } } )
+              when not (List.mem meth hidden_methods) ->
+                methods meth
+            | _ -> None
+        in
+        match (invoked_value, invoke_default) with
           (* If method returns `null` and a default is provided, pick default. *)
           | Some (Value.Null { methods }), Some default
             when Methods.is_empty methods ->