Add typeof

src/lang/lexer.ml

@@ -219,6 +219,7 @@ let rec token lexbuf =
     | '=' -> GETS
     | "end" -> END
     | "begin" -> BEGIN
+    | "typeof" -> TYPEOF
     | "if" -> IF
     | "then" -> THEN
     | "else" -> ELSE

src/lang/parser.mly

@@ -40,6 +40,7 @@ open Parser_helper
 %token <Parsed_term.time_el> TIME
 %token <Parsed_term.time_el * Parsed_term.time_el> INTERVAL
 %token <string> ENCODER
+%token TYPEOF
 %token EOF
 %token <Parser_helper.lexer_let_decoration> LET
 %token <Parser_helper.lexer_let_decoration> LETLBRA
@@ -83,6 +84,7 @@ open Parser_helper
 %nonassoc YIELDS       (* fun x -> (x+x) *)
 %right SET             (* expr := (expr + expr), expr := (expr := expr) *)
 %nonassoc QUESTION     (* x ? y : z *)
+%nonassoc TYPEOF (* typeof v? *)
 %left AND             (* ((x+(y*z))==3) or ((not a)==b) *)
 %left OR
 %nonassoc NOT
@@ -295,6 +297,7 @@ ty:
   | ty QUESTION_DOT LCUR record_ty RCUR
                                  { `Method (`Nullable $1, $4) }
   | ty DOT LCUR record_ty RCUR   { `Method ($1, $4) }
+  | TYPEOF expr                  { `Typeof $2 }
   | ty_source                    { `Source $1 }
 
 record_ty:
@@ -303,15 +306,15 @@ record_ty:
   | meth_ty COMMA record_ty { $1::$3 }
 
 meth_ty:
-  | VAR COLON ty            { { optional = false; name = $1; typ = $3; json_name = None } }
-  | VAR QUESTION COLON ty   { { optional = true; name = $1; typ = $4; json_name = None } }
+  | VAR COLON ty            { { optional_meth = false; name = $1; typ = $3; json_name = None } }
+  | VAR QUESTION COLON ty   { { optional_meth = true; name = $1; typ = $4; json_name = None } }
   | STRING VAR VAR COLON ty {
        match $2 with
-         |"as" ->             { optional = false; name = $3; typ = $5; json_name = Some (render_string ~pos:$loc $1) }
+         |"as" ->             { optional_meth = false; name = $3; typ = $5; json_name = Some (render_string ~pos:$loc $1) }
          | _ -> raise (Term_base.Parse_error ($loc, "Invalid type constructor")) }
   | STRING VAR VAR QUESTION COLON ty {
        match $2 with
-         |"as" ->             { optional = true; name = $3; typ = $6; json_name = Some (render_string ~pos:$loc $1) }
+         |"as" ->             { optional_meth = true; name = $3; typ = $6; json_name = Some (render_string ~pos:$loc $1) }
          | _ -> raise (Term_base.Parse_error ($loc, "Invalid type constructor")) }
 
 ty_source:

src/lang/parser_helper.ml

@@ -104,76 +104,6 @@ let attach_comments term =
     !pending_comments;
   pending_comments := []
 
-let mk_source_ty ?pos name args =
-  let fn = !Hooks.mk_source_ty in
-  fn ?pos name args
-
-let mk_clock_ty ?pos () =
-  let fn = !Hooks.mk_clock_ty in
-  fn ?pos ()
-
-let mk_named_ty ?pos = function
-  | "_" -> Type.var ?pos:(Option.map Pos.of_lexing_pos pos) ()
-  | "unit" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.unit
-  | "never" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.Never
-  | "bool" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.Bool
-  | "int" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.Int
-  | "float" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.Float
-  | "string" -> Type.make ?pos:(Option.map Pos.of_lexing_pos pos) Type.String
-  | "ref" -> Type.reference (Type.var ())
-  | "clock" -> mk_clock_ty ?pos ()
-  | "source" -> mk_source_ty ?pos "source" { extensible = true; tracks = [] }
-  | "source_methods" -> !Hooks.source_methods_t ()
-  | name -> (
-      match Type.find_opt_typ name with
-        | Some c -> c ()
-        | None ->
-            let pos =
-              Option.value ~default:(Lexing.dummy_pos, Lexing.dummy_pos) pos
-            in
-            raise
-              (Term_base.Parse_error
-                 (pos, "Unknown type constructor: " ^ name ^ ".")))
-
-let rec mk_ty ?pos = function
-  | `Named s -> mk_named_ty ?pos s
-  | `Nullable t -> Type.(make (Nullable (mk_ty ?pos t)))
-  | `List t -> Type.(make (List { t = mk_ty ?pos t; json_repr = `Tuple }))
-  | `Json_object t ->
-      Type.(
-        make
-          (List
-             {
-               t = mk_ty ?pos (`Tuple [`Named "string"; t]);
-               json_repr = `Object;
-             }))
-  | `Tuple l -> Type.(make (Tuple (List.map (mk_ty ?pos) l)))
-  | `Arrow (args, t) ->
-      Type.(
-        make
-          (Arrow
-             ( List.map
-                 (fun (optional, name, t) -> (optional, name, mk_ty ?pos t))
-                 args,
-               mk_ty ?pos t )))
-  | `Record l -> List.fold_left (mk_meth_ty ?pos) Type.(make (Tuple [])) l
-  | `Method (t, l) -> List.fold_left (mk_meth_ty ?pos) (mk_ty ?pos t) l
-  | `Invoke (t, s) -> snd (Type.invoke (mk_ty ?pos t) s)
-  | `Source (s, p) -> mk_source_ty ?pos s p
-
-and mk_meth_ty ?pos base { Term.name; optional; typ; json_name } =
-  Type.(
-    make
-      (Meth
-         ( {
-             meth = name;
-             optional;
-             scheme = ([], mk_ty ?pos typ);
-             doc = "";
-             json_name;
-           },
-           base )))
-
 let let_args ~decoration ~pat ?arglist ~def ?cast () =
   { decoration; pat; arglist; def; cast }
 

src/lang/parser_helper.mli

@@ -46,7 +46,6 @@ type let_opt_el = string * Term.t
 val clear_comments : unit -> unit
 val append_comment : pos:pos -> string -> unit
 val attach_comments : Term.t -> unit
-val mk_ty : ?pos:pos -> Parsed_term.type_annotation -> Type.t
 
 val mk_let :
   pos:pos ->

src/lang/pos.ml

@@ -74,17 +74,17 @@ let to_string ?(prefix = "at ") pos =
 let string_of_pos = to_string
 
 module Option = struct
-  type nonrec t = t option
+  type base = t
+  type t = base option
 
   let to_string ?prefix : t -> string = function
     | Some pos -> to_string ?prefix pos
     | None -> "unknown position"
 end
 
 module List = struct
-  (** A list of positions, corresponding to a stack of calls. The toplevel one
-      is the external caller and the last one is the callee. *)
-  type nonrec t = t list
+  type base = t
+  type t = base list
 
   (** The most relevant position in a call stack. *)
   let rec to_pos = function

src/lang/pos.mli

@@ -0,0 +1,55 @@
+(*****************************************************************************
+
+  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
+
+ *****************************************************************************)
+
+(** Operations on positions (in source files). *)
+
+type t
+
+type pos = {
+  fname : string;
+  lstart : int;
+  lstop : int;
+  cstart : int;
+  cstop : int;
+}
+
+val pack_offset : int
+val pack : pos -> t
+val unpack : t -> pos
+val of_lexing_pos : Lexing.position * Lexing.position -> t
+val to_string : ?prefix:string -> t -> string
+val string_of_pos : ?prefix:string -> t -> string
+
+module Option : sig
+  type base = t
+  type t = base option
+
+  val to_string : ?prefix:string -> t -> string
+end
+
+module List : sig
+  type base = t
+  type t = base list
+
+  val to_pos : t -> base
+  val to_string : ?newlines:bool -> ?prefix:string -> t -> string
+end

src/lang/repr.ml

@@ -195,6 +195,7 @@ let make ?(filter_out = fun _ -> false) ?(generalized = []) t : t =
             `Arrow
               ( List.map (fun (opt, lbl, t) -> (opt, lbl, repr g t)) args,
                 repr g t )
+        | Var { contents = Typeof t } -> repr g (Lazy.force t)
         | Var { contents = Free var } ->
             if List.exists (Var.eq var) g then uvar g var else evar var
         | Var { contents = Link (`Covariant, t) } when !debug || !debug_variance

src/lang/runtime.ml

@@ -204,6 +204,12 @@ let throw ?(formatter = Format.std_formatter) ?lexbuf () =
         (Printexc.to_string e) bt;
       raise Error
 
+let () =
+  Term_reducer.typecheck :=
+    fun ?env tm ->
+      let throw = throw () in
+      Typechecking.check ?env ~throw tm
+
 (* This is not great but it works for now. The problem being that we are relying on exception
    raising and catching to transmit language error, translate them into human readable errors and
    optionally ignore them with a warning. But, in some cases, we still want to return afterward

src/lang/term/parsed_term.ml

@@ -55,39 +55,6 @@ and pattern_entry =
 
 and meth_term_default = [ `Nullable | `Pattern of pattern | `None ]
 
-type meth_annotation = {
-  optional : bool;
-  name : string;
-  typ : type_annotation;
-  json_name : string option;
-}
-
-and source_track_annotation = {
-  track_name : string;
-  track_type : string;
-  track_params : track_annotation list;
-}
-
-and source_annotation = {
-  extensible : bool;
-  tracks : source_track_annotation list;
-}
-
-and argument = bool * string * type_annotation
-
-and type_annotation =
-  [ `Named of string
-  | `Nullable of type_annotation
-  | `List of type_annotation
-  | `Json_object of type_annotation
-  | `Tuple of type_annotation list
-  | `Arrow of argument list * type_annotation
-  | `Record of meth_annotation list
-  | `Method of type_annotation * meth_annotation list
-  | `Invoke of type_annotation * string
-  | `Source of string * source_annotation ]
-[@@deriving hash]
-
 type _of = { only : string list; except : string list; source : string }
 [@@deriving hash]
 
@@ -171,6 +138,39 @@ and time_el = {
   seconds : int option;
 }
 
+and meth_annotation = {
+  optional_meth : bool;
+  name : string;
+  typ : type_annotation;
+  json_name : string option;
+}
+
+and source_track_annotation = {
+  track_name : string;
+  track_type : string;
+  track_params : track_annotation list;
+}
+
+and source_annotation = {
+  extensible : bool;
+  tracks : source_track_annotation list;
+}
+
+and argument = bool * string * type_annotation
+
+and type_annotation =
+  [ `Named of string
+  | `Nullable of type_annotation
+  | `List of type_annotation
+  | `Json_object of type_annotation
+  | `Tuple of type_annotation list
+  | `Arrow of argument list * type_annotation
+  | `Record of meth_annotation list
+  | `Method of type_annotation * meth_annotation list
+  | `Invoke of type_annotation * string
+  | `Typeof of t
+  | `Source of string * source_annotation ]
+
 (* These terms are reduced at runtime *)
 and parsed_ast =
   [ `If of _if