From e1a769e8374951b04e304517af44c040a9dc0b7a Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 14 Nov 2024 23:02:39 +0000 Subject: [PATCH] refactor: get rid of stdune from code generator Signed-off-by: Rudi Grinberg --- lsp/bin/cinaps.ml | 16 ++++--- lsp/bin/dune | 4 +- lsp/bin/import.ml | 81 +++++++++++++++++++++++++++----- lsp/bin/metamodel/metamodel.ml | 10 ++-- lsp/bin/ocaml/json_gen.ml | 2 +- lsp/bin/ocaml/ml.ml | 2 +- lsp/bin/ocaml/ocaml.ml | 24 +++++----- lsp/bin/typescript/ts_types.ml | 65 +++++++++++++++++++++---- lsp/bin/typescript/ts_types.mli | 16 +++---- lsp/bin/typescript/typescript.ml | 2 +- 10 files changed, 164 insertions(+), 58 deletions(-) diff --git a/lsp/bin/cinaps.ml b/lsp/bin/cinaps.ml index 81073a695..ea6649cc4 100644 --- a/lsp/bin/cinaps.ml +++ b/lsp/bin/cinaps.ml @@ -7,7 +7,7 @@ let preprocess_metamodel = method! or_ path (types : Metamodel.type_ list) = match List.filter_map types ~f:(function - | Literal (Record []) -> None + | Metamodel.Literal (Record []) -> None | _ as t -> Some (self#type_ path t)) with | [] -> assert false @@ -17,10 +17,13 @@ let preprocess_metamodel = | Top (Alias s) when s.name = "TextDocumentContentChangeEvent" -> let t = let union_fields l1 l2 ~f = - let of_map = - String.Map.of_list_map_exn ~f:(fun (x : Metamodel.property) -> x.name, x) + let of_map xs = + List.map xs ~f:(fun (x : Metamodel.property) -> x.name, x) + |> String.Map.of_list in - String.Map.merge (of_map l1) (of_map l2) ~f |> String.Map.values + String.Map.merge (of_map l1) (of_map l2) ~f + |> String.Map.bindings + |> List.map ~f:snd in union_fields f1 f2 ~f:(fun k t1 t2 -> if k = "text" @@ -81,8 +84,9 @@ let expand_superclasses db (m : Metamodel.t) = let structures = let uniquify_fields fields = List.fold_left fields ~init:String.Map.empty ~f:(fun acc (f : Metamodel.property) -> - String.Map.set acc f.name f) - |> String.Map.values + String.Map.add acc ~key:f.name ~data:f) + |> String.Map.bindings + |> List.map ~f:snd in let rec fields_of_type (t : Metamodel.type_) = match t with diff --git a/lsp/bin/dune b/lsp/bin/dune index 6c2b237e6..1284abbaf 100644 --- a/lsp/bin/dune +++ b/lsp/bin/dune @@ -3,7 +3,7 @@ (test (name test_metamodel) (modules test_metamodel) - (libraries stdune yojson lsp_gen) + (libraries yojson lsp_gen) (deps metamodel/metaModel.json) (action (run ./test_metamodel.exe %{deps}))) @@ -13,4 +13,4 @@ (instrumentation (backend bisect_ppx)) (modules :standard \ test_metamodel) - (libraries stdune dyn pp yojson)) + (libraries dyn pp yojson)) diff --git a/lsp/bin/import.ml b/lsp/bin/import.ml index c1b414f8f..d42629d14 100644 --- a/lsp/bin/import.ml +++ b/lsp/bin/import.ml @@ -1,13 +1,70 @@ -include struct - open Stdune - module List = List - module Id = Id - module String = String - module Code_error = Code_error - module Comparable = Comparable - module Top_closure = Top_closure - module Poly = Poly - module Option = Option - - let sprintf = sprintf +let sprintf = Printf.sprintf + +module Option = struct + include Option + + let map t ~f = Option.map f t + + let value_exn = function + | None -> assert false + | Some s -> s + ;; +end + +module List = struct + include ListLabels + + type ('a, 'b) skip_or_either = + | Skip + | Left of 'a + | Right of 'b + + let rev_filter_partition_map = + let rec loop l accl accr ~f = + match l with + | [] -> accl, accr + | x :: l -> + (match f x with + | Skip -> loop l accl accr ~f + | Left y -> loop l (y :: accl) accr ~f + | Right y -> loop l accl (y :: accr) ~f) + in + fun l ~f -> loop l [] [] ~f + ;; + + let filter_partition_map l ~f = + let l, r = rev_filter_partition_map l ~f in + rev l, rev r + ;; +end + +module String = struct + include StringLabels + + let to_dyn = Dyn.string + + module Map = struct + include MoreLabels.Map.Make (String) + + let of_list_reducei xs ~f = + List.fold_left xs ~init:empty ~f:(fun map (k, v) -> + update map ~key:k ~f:(function + | None -> Some v + | Some v' -> Some (f k v v'))) + ;; + + let of_list_map_exn xs ~f = List.map xs ~f |> of_list + let union_exn x y = union ~f:(fun _ _ _ -> assert false) x y + end +end + +module Code_error = struct + let raise name data = + invalid_arg (sprintf "%s %s" name (Dyn.to_string (Dyn.record data))) + ;; +end + +module Poly = struct + let equal = Stdlib.( = ) + let compare = Stdlib.compare end diff --git a/lsp/bin/metamodel/metamodel.ml b/lsp/bin/metamodel/metamodel.ml index d9be957da..72d418621 100644 --- a/lsp/bin/metamodel/metamodel.ml +++ b/lsp/bin/metamodel/metamodel.ml @@ -1,4 +1,4 @@ -open Stdune +open Import type doc = { since : string option @@ -113,7 +113,7 @@ let fields = function ;; let field ?default (name : string) p fields = - match List.assoc fields name with + match List.assoc_opt name fields with | Some f -> p f | None -> (match default with @@ -122,7 +122,7 @@ let field ?default (name : string) p fields = ;; let field_o name p fields = - match List.assoc fields name with + match List.assoc_opt name fields with | None -> None | Some f -> Some (p f) ;; @@ -137,7 +137,7 @@ let literal lit json = if not (Poly.equal json lit) then error "unexpected liter let enum variants json = match json with | `String s -> - (match List.assoc variants s with + (match List.assoc_opt s variants with | None -> error "not a valid enum value" json | Some v -> v) | _ -> error "not a valid enum value" json @@ -370,7 +370,7 @@ module Entity = struct String.Map.union_exn structures enumerations |> String.Map.union_exn typeAliases ;; - let find t x = String.Map.find_exn t x + let find t x = String.Map.find x t end end diff --git a/lsp/bin/ocaml/json_gen.ml b/lsp/bin/ocaml/json_gen.ml index 44af31da8..7f26ced93 100644 --- a/lsp/bin/ocaml/json_gen.ml +++ b/lsp/bin/ocaml/json_gen.ml @@ -34,7 +34,7 @@ let json_error_pat msg = ;; let is_json_constr (constr : Type.constr) = - List.mem [ "String"; "Int"; "Bool" ] constr.name ~equal:String.equal + List.mem ~set:[ "String"; "Int"; "Bool" ] constr.name ;; module Name = struct diff --git a/lsp/bin/ocaml/ml.ml b/lsp/bin/ocaml/ml.ml index 4973e02e2..7d76e8a9b 100644 --- a/lsp/bin/ocaml/ml.ml +++ b/lsp/bin/ocaml/ml.ml @@ -409,7 +409,7 @@ module Expr = struct let pp_constr f { tag; poly; args } = let tag = - let tag = String.capitalize tag in + let tag = String.capitalize_ascii tag in Pp.verbatim (if poly then "`" ^ tag else tag) in match args with diff --git a/lsp/bin/ocaml/ocaml.ml b/lsp/bin/ocaml/ocaml.ml index fe20955fc..5128925ca 100644 --- a/lsp/bin/ocaml/ocaml.ml +++ b/lsp/bin/ocaml/ocaml.ml @@ -79,9 +79,7 @@ module Expanded = struct | None -> init | Some data -> let new_record = { f with data } in - if List.mem ~equal:Poly.equal init new_record - then init - else new_record :: init) + if List.mem ~set:init new_record then init else new_record :: init) in super#field f ~init end @@ -274,18 +272,18 @@ module Entities = struct type t = (Ident.t * Resolved.t) list let find db e : _ Named.t = - match List.assoc db e with + match List.assoc_opt e db with | Some s -> s | None -> Code_error.raise "Entities.find: unable to find" [ "e", Ident.to_dyn e ] ;; let of_map map ts = - List.map ts ~f:(fun (r : Resolved.t) -> String.Map.find_exn map r.name, r) + List.map ts ~f:(fun (r : Resolved.t) -> String.Map.find r.name map, r) ;; let rev_find (db : t) (resolved : Resolved.t) : Ident.t = match - List.filter_map db ~f:(fun (id, r) -> + List.filter_map db ~f:(fun (id, (r : Resolved.t)) -> if r.name = resolved.name then Some id else None) with | [] -> Code_error.raise "rev_find: resolved not found" [] @@ -327,17 +325,17 @@ end = struct [ Prim.Null; String; Bool; Number; Object; List ] |> List.map ~f:(fun s -> Resolved.Ident s) in - fun set -> List.for_all constrs ~f:(fun e -> List.mem set e ~equal:Poly.equal) + fun set -> List.for_all constrs ~f:(List.mem ~set) ;; let id = Type.name "Jsonrpc.Id.t" let is_same_as_id = - let sort = List.sort ~compare:Poly.compare in + let sort = List.sort ~cmp:Poly.compare in let constrs = [ Prim.String; Number ] |> List.map ~f:(fun s -> Resolved.Ident s) |> sort in - fun cs -> List.equal ( = ) constrs (sort cs) + fun cs -> List.equal ~eq:( = ) constrs (sort cs) ;; (* Any type that includes null needs to be extracted to be converted to an @@ -585,7 +583,7 @@ end = struct let literal_wrapper = match literal_wrapper with | None -> [] - | Some { field_name; literal_value } -> + | Some { Mapper.field_name; literal_value } -> Json_gen.make_literal_wrapper_conv ~field_name ~literal_value @@ -626,7 +624,7 @@ let resolve_typescript (ts : Unresolved.t list) = let db = Entities.of_map db ts in match let idents = new name_idents in - Ident.Top_closure.top_closure + Ident.top_closure ts ~key:(fun x -> Entities.rev_find db x) ~deps:(fun x -> idents#t x ~init:[] |> List.map ~f:(Entities.find db)) @@ -640,7 +638,7 @@ let resolve_typescript (ts : Unresolved.t list) = let of_resolved_typescript db (ts : Resolved.t list) = let simple_enums, everything_else = List.filter_partition_map ts ~f:(fun (t : Resolved.t) -> - if List.mem skipped_ts_decls t.name ~equal:String.equal + if List.mem ~set:skipped_ts_decls t.name then Skip else ( match t.data with @@ -650,7 +648,7 @@ let of_resolved_typescript db (ts : Resolved.t list) = let simple_enums = List.map simple_enums ~f:(fun (t : _ Named.t) -> (* "open" enums need an `Other constructor *) - let allow_other = List.mem ~equal:String.equal with_custom_values t.name in + let allow_other = List.mem ~set:with_custom_values t.name in let data = List.filter_map t.data ~f:(fun (constr, v) -> match (v : Ts_types.Enum.case) with diff --git a/lsp/bin/typescript/ts_types.ml b/lsp/bin/typescript/ts_types.ml index c454410ed..c6206f45c 100644 --- a/lsp/bin/typescript/ts_types.ml +++ b/lsp/bin/typescript/ts_types.ml @@ -262,7 +262,19 @@ module Unresolved = struct end module Ident = struct - module Id = Stdune.Id.Make () + module Id = struct + type t = int + + let counter = ref 0 + + let gen () = + incr counter; + !counter + ;; + + let compare = Int.compare + let to_dyn = Dyn.int + end module T = struct type t = @@ -282,9 +294,44 @@ module Ident = struct let make name = { name; id = Id.gen () } - module C = Comparable.Make (T) - module Set = C.Set - module Top_closure = Top_closure.Make (Set) (Stdune.Monad.Id) + module Keys = struct + include MoreLabels.Set.Make (T) + + let add x y = add y x + let mem x y = mem y x + end + + let top_closure ~key ~deps elements = + let rec loop res visited elt ~temporarily_marked = + let key = key elt in + if Keys.mem temporarily_marked key + then Error [ elt ] + else if not (Keys.mem visited key) + then ( + let visited = Keys.add visited key in + let temporarily_marked = Keys.add temporarily_marked key in + deps elt + |> iter_elts res visited ~temporarily_marked + |> function + | Error l -> Error (elt :: l) + | Ok (res, visited) -> + let res = elt :: res in + Ok (res, visited)) + else Ok (res, visited) + and iter_elts res visited elts ~temporarily_marked = + match elts with + | [] -> Ok (res, visited) + | elt :: elts -> + loop res visited elt ~temporarily_marked + |> (function + | Error _ as result -> result + | Ok (res, visited) -> iter_elts res visited elts ~temporarily_marked) + in + iter_elts [] Keys.empty elements ~temporarily_marked:Keys.empty + |> function + | Ok (res, _visited) -> Ok (List.rev res) + | Error elts -> Error elts + ;; end module Prim = struct @@ -345,15 +392,15 @@ let subst unresolved = method inside s = {} method resolve n = - match String.Map.find params n with + match String.Map.find_opt n params with | Some [] -> assert false | Some (x :: _) -> `Resolved x | None -> - if inside = Some n then `Self else `Unresolved (String.Map.find_exn unresolved n) + if inside = Some n then `Self else `Unresolved (String.Map.find n unresolved) method push x y = let params = - String.Map.update params x ~f:(function + String.Map.update params ~key:x ~f:(function | None -> Some [ y ] | Some [] -> assert false | Some (y' :: xs) -> if y = y' then Some xs else Some (y :: y' :: xs)) @@ -362,9 +409,9 @@ let subst unresolved = method pop x = let params = - String.Map.update params x ~f:(function + String.Map.update params ~key:x ~f:(function | None -> - ignore (String.Map.find_exn params x); + ignore (String.Map.find x params); None | Some [] -> assert false | Some (_ :: xs) -> Some xs) diff --git a/lsp/bin/typescript/ts_types.mli b/lsp/bin/typescript/ts_types.mli index aa33961b9..7f3f72904 100644 --- a/lsp/bin/typescript/ts_types.mli +++ b/lsp/bin/typescript/ts_types.mli @@ -86,7 +86,9 @@ module Unresolved : sig end module Ident : sig - module Id : Id.S + module Id : sig + type t + end type t = { id : Id.t @@ -96,13 +98,11 @@ module Ident : sig val to_dyn : t -> Dyn.t val make : string -> t - module Top_closure : sig - val top_closure - : key:('a -> t) - -> deps:('a -> 'a list) - -> 'a list - -> ('a list, 'a list) result - end + val top_closure + : key:('a -> t) + -> deps:('a -> 'a list) + -> 'a list + -> ('a list, 'a list) result end module Prim : sig diff --git a/lsp/bin/typescript/typescript.ml b/lsp/bin/typescript/typescript.ml index c8f7847cc..4f26e5abd 100644 --- a/lsp/bin/typescript/typescript.ml +++ b/lsp/bin/typescript/typescript.ml @@ -19,7 +19,7 @@ let name_table (defns : Unresolved.t list) = let resolve_all (defns : Unresolved.t list) = let names = name_table defns in - let defns = String.Map.values names |> List.map ~f:fst in + let defns = String.Map.bindings names |> List.map ~f:snd |> List.map ~f:fst in let names = String.Map.map ~f:snd names in Ts_types.resolve_all defns ~names, names ;;