Cleanup preliminary to typeof changes.

savonet · Jan 3, 2025 · 2f4ba0b · 2f4ba0b
1 parent 0b02cee
commit 2f4ba0b
Show file tree

Hide file tree

Showing 9 changed files with 217 additions and 134 deletions.
diff --git a/src/lang/parser.mly b/src/lang/parser.mly
@@ -303,15 +303,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:

diff --git a/src/lang/parser_helper.ml b/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 }
 

diff --git a/src/lang/parser_helper.mli b/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 ->

diff --git a/src/lang/pos.ml b/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

diff --git a/src/lang/pos.mli b/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
diff --git a/src/lang/term/parsed_term.ml b/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,38 @@ 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
+  | `Source of string * source_annotation ]
+
 (* These terms are reduced at runtime *)
 and parsed_ast =
   [ `If of _if

diff --git a/src/lang/term/term_reducer.ml b/src/lang/term/term_reducer.ml
@@ -35,6 +35,97 @@ let mk_parsed = Parsed_term.make
 let mk_fun ~pos arguments body =
   mk ~pos (`Fun Term.{ free_vars = None; name = None; arguments; body })
 
+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 typecheck = ref (fun ?env:_ _ -> assert false)
+
+let rec mk_parsed_ty ?pos ~env ~to_term = function
+  | `Named s -> mk_named_ty ?pos s
+  | `Nullable t ->
+      Type.(
+        make
+          ?pos:(Option.map Pos.of_lexing_pos pos)
+          (Nullable (mk_parsed_ty ?pos ~env ~to_term t)))
+  | `List t ->
+      Type.(
+        make
+          ?pos:(Option.map Pos.of_lexing_pos pos)
+          (List { t = mk_parsed_ty ?pos ~env ~to_term t; json_repr = `Tuple }))
+  | `Json_object t ->
+      Type.(
+        make
+          (List
+             {
+               t = mk_parsed_ty ?pos ~env ~to_term (`Tuple [`Named "string"; t]);
+               json_repr = `Object;
+             }))
+  | `Tuple l ->
+      Type.(
+        make
+          ?pos:(Option.map Pos.of_lexing_pos pos)
+          (Tuple (List.map (mk_parsed_ty ~env ~to_term ?pos) l)))
+  | `Arrow (args, t) ->
+      Type.(
+        make
+          (Arrow
+             ( List.map
+                 (fun (optional, name, t) ->
+                   (optional, name, mk_parsed_ty ~env ~to_term ?pos t))
+                 args,
+               mk_parsed_ty ?pos ~env ~to_term t )))
+  | `Record l ->
+      List.fold_left (mk_meth_ty ?pos ~env ~to_term) Type.(make (Tuple [])) l
+  | `Method (t, l) ->
+      List.fold_left
+        (mk_meth_ty ?pos ~env ~to_term)
+        (mk_parsed_ty ?pos ~env ~to_term t)
+        l
+  | `Invoke (t, s) -> snd (Type.invoke (mk_parsed_ty ?pos ~env ~to_term t) s)
+  | `Source (s, p) -> mk_source_ty ?pos s p
+
+and mk_meth_ty ?pos ~env ~to_term base
+    { Parsed_term.name; optional_meth = optional; typ; json_name } =
+  Type.(
+    make
+      (Meth
+         ( {
+             meth = name;
+             optional;
+             scheme = ([], mk_parsed_ty ?pos ~env ~to_term typ);
+             doc = "";
+             json_name;
+           },
+           base )))
+
 let program = Term_preprocessor.program
 
 let mk_expr ?fname processor lexbuf =
@@ -573,7 +664,7 @@ let expand_argsof ~pos ~env ~to_term args =
                typ =
                  (match arg.typ with
                    | None -> mk_var ()
-                   | Some typ -> Parser_helper.mk_ty typ);
+                   | Some typ -> mk_parsed_ty ~env ~to_term typ);
                default = Option.map (to_term ~env) arg.default;
              }
              :: args)
@@ -1051,7 +1142,7 @@ let mk_let ~env ~pos ~to_term ~comments
     in
     to_term ~env body
   in
-  let cast = Option.map (Parser_helper.mk_ty ~pos) cast in
+  let cast = Option.map (mk_parsed_ty ~pos ~env ~to_term) cast in
   let arglist = Option.map (expand_argsof ~pos ~env ~to_term) arglist in
   let doc =
     match
@@ -1196,7 +1287,8 @@ let rec to_ast ~env ~pos ~comments ast =
           parse_error ~pos (Printf.sprintf "Invalid float value: %s" f))
     | `Null -> `Null
     | `Cast { cast = t; typ } ->
-        `Cast { cast = to_term ~env t; typ = Parser_helper.mk_ty ~pos typ }
+        `Cast
+          { cast = to_term ~env t; typ = mk_parsed_ty ~pos ~env ~to_term typ }
     | `Invoke { invoked; optional; meth } ->
         let default = if optional then Some (mk_parsed ~pos `Null) else None in
         mk_invoke ~pos ~env ?default ~to_term invoked meth

diff --git a/src/lang/term/term_reducer.mli b/src/lang/term/term_reducer.mli
@@ -28,6 +28,7 @@ type processor =
   MenhirLib.Convert.revised
 
 val program : processor
+val typecheck : (?env:Typing.env -> Term.t -> unit) ref
 val mk_expr : ?fname:string -> processor -> Sedlexing.lexbuf -> Parsed_term.t
 val to_term : Parsed_term.t -> Term.t
 val to_encoder_params : Parsed_term.encoder_params -> Term.encoder_params