From 88819e36e3ea3bb86bc43598fc391f89942ae007 Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 8 Oct 2024 17:16:27 +0200 Subject: [PATCH 01/24] Proof of concept to print type_expr --- tools/src/print_tast.ml | 265 ++++++++++++++++++++++++++++++++++++++++ tools/src/tools.ml | 18 ++- 2 files changed, 282 insertions(+), 1 deletion(-) create mode 100644 tools/src/print_tast.ml diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml new file mode 100644 index 000000000..98380930e --- /dev/null +++ b/tools/src/print_tast.ml @@ -0,0 +1,265 @@ +(* *) + +(** Transform the AST types to the more generic Oak format *) +module Oak = struct + type application = {name: string; argument: oak} + + and namedField = {name: string; value: oak} + + and oak = + | Application of application + | Record of namedField list + | Ident of string + | Tuple of namedField list + | List of oak list + + let rec path_to_string = function + | Path.Pident id -> Ident.name id + | Path.Pdot (p, s, _) -> path_to_string p ^ "." ^ s + | Path.Papply (p1, p2) -> path_to_string p1 ^ "(" ^ path_to_string p2 ^ ")" + + let rec mk_type_desc (desc : Types.type_desc) : oak = + match desc with + | Tvar _ -> Ident "type_desc.Tvar" + | Tarrow (_, t1, t2, _) -> + Application + { + name = "type_desc.Tarrow"; + argument = + Tuple + [ + {name = "t1"; value = mk_type_desc t1.desc}; + {name = "t2"; value = mk_type_desc t2.desc}; + ]; + } + | Ttuple _ -> Ident "type_desc.Ttuple" + | Tconstr (path, ts, _) -> + let ts = + ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) + in + Application + { + name = "type_desc.Tconstr"; + argument = + Tuple + [ + {name = "path"; value = Ident (path_to_string path)}; + {name = "ts"; value = List ts}; + ]; + } + | Tobject _ -> Ident "type_desc.Tobject" + | Tfield _ -> Ident "type_desc.Tfield" + | Tnil -> Ident "type_desc.Tnil" + | Tlink {desc} -> Ident "type_desc.Tlink" + | Tsubst _ -> Ident "type_desc.Tsubst" + | Tvariant row_descr -> Ident "type_desc.Tvariant" + | Tunivar _ -> Ident "type_desc.Tunivar" + | Tpoly _ -> Ident "type_desc.Tpoly" + | Tpackage _ -> Ident "type_desc.Tpackage" +end + +(** Transform the Oak types to string *) +module CodePrinter = struct + type writerEvents = + | Write of string + | WriteLine + | IndentBy of int + | UnindentBy of int + + type context = { + indent_size: int; + max_line_length: int; + current_indent: int; + current_line_column: int; + events: writerEvents list; + } + + let countLines (ctx : context) = + ctx.events + |> List.filter (fun event -> + match event with + | WriteLine -> true + | _ -> false) + |> List.length + + type appendEvents = context -> context + + let emptyContext = + { + indent_size = 2; + max_line_length = 80; + current_indent = 0; + current_line_column = 0; + events = []; + } + + (* Type representing the writer context during code printing + + - [indent_size] is the configured indentation size, typically 2 + - [current_indent] is the current indentation size + - [current_line_column] is the characters written on the current line + - [events] is the write events in reverse order, head event is last written + *) + + let id x = x + + (** add a write event to the context *) + let ( !- ) str ctx = + { + ctx with + events = Write str :: ctx.events; + current_line_column = ctx.current_line_column + String.length str; + } + + (** compose two context transforming functions *) + let ( +> ) f g ctx = g (f ctx) + + let sepNln ctx = + {ctx with events = WriteLine :: ctx.events; current_line_column = 0} + + let sepComma ctx = !-", " ctx + let sepSemi ctx = !-"; " ctx + let sepOpenT ctx = !-"(" ctx + let sepCloseT ctx = !-")" ctx + let sepOpenR ctx = !-"{" ctx + let sepCloseR ctx = !-"}" ctx + let sepOpenL ctx = !-"[" ctx + let sepCloseL ctx = !-"]" ctx + let sepEq ctx = !-" = " ctx + let indent ctx = + let nextIdent = ctx.current_indent + ctx.indent_size in + { + ctx with + current_indent = nextIdent; + current_line_column = nextIdent; + events = IndentBy ctx.indent_size :: ctx.events; + } + let unindent ctx = + let nextIdent = ctx.current_indent - ctx.indent_size in + { + ctx with + current_indent = nextIdent; + current_line_column = nextIdent; + events = UnindentBy ctx.indent_size :: ctx.events; + } + + let indentAndNln f = indent +> sepNln +> f +> unindent + + let col (f : 't -> appendEvents) (intertwine : appendEvents) items ctx = + let rec visit items ctx = + match items with + | [] -> ctx + | [item] -> f item ctx + | item :: rest -> + let ctx' = (f item +> intertwine) ctx in + visit rest ctx' + in + visit items ctx + + let expressionFitsOnRestOfLine (f : appendEvents) (fallback : appendEvents) + (ctx : context) = + let current_line_count = countLines ctx in + let shortCtx = f ctx in + let nextLineCount = countLines shortCtx in + if + current_line_count == nextLineCount + && shortCtx.current_line_column <= ctx.max_line_length + then shortCtx + else fallback ctx + + (** Fold all the events in context into text *) + let dump (ctx : context) = + let addSpaces n = String.make n ' ' in + + List.fold_right + (fun event (acc, current_indent) -> + match event with + | Write str -> (acc ^ str, current_indent) + | WriteLine -> (acc ^ "\n" ^ addSpaces current_indent, current_indent) + | IndentBy n -> (acc, current_indent + n) + | UnindentBy n -> (acc, current_indent - n)) + ctx.events ("", 0) + |> fst + + let rec genOak (oak : Oak.oak) : appendEvents = + match oak with + | Oak.Application application -> genApplication application + | Oak.Record record -> genRecord record + | Oak.Ident ident -> genIdent ident + | Oak.Tuple ts -> genTuple ts + | Oak.List xs -> genList xs + + and genApplication (application : Oak.application) : appendEvents = + let short = + !-(application.name) +> sepOpenT + +> genOak application.argument + +> sepCloseT + in + let long = + !-(application.name) +> sepOpenT + +> indentAndNln (genOak application.argument) + +> sepNln +> sepCloseT + in + expressionFitsOnRestOfLine short long + + and genRecord (recordFields : Oak.namedField list) : appendEvents = + let short = + sepOpenR +> col genNamedField sepSemi recordFields +> sepCloseR + in + let long = + sepOpenR + +> indentAndNln (col genNamedField sepNln recordFields) + +> sepNln +> sepCloseR + in + expressionFitsOnRestOfLine short long + + and genTuple (oaks : Oak.namedField list) : appendEvents = + let short = col genNamedField sepComma oaks in + let long = col genNamedField sepNln oaks in + expressionFitsOnRestOfLine short long + + and genIdent (ident : string) : appendEvents = !-ident + + and genNamedField (field : Oak.namedField) : appendEvents = + let short = !-(field.name) +> sepEq +> genOak field.value in + let long = + !-(field.name) +> sepEq + +> + match field.value with + | Oak.List _ -> genOak field.value + | _ -> indentAndNln (genOak field.value) + in + expressionFitsOnRestOfLine short long + + and genList (items : Oak.oak list) : appendEvents = + let short = sepOpenL +> col genOak sepSemi items +> sepCloseL in + let long = + sepOpenL +> indentAndNln (col genOak sepNln items) +> sepNln +> sepCloseL + in + expressionFitsOnRestOfLine short long +end + +let print_type_expr (typ : Types.type_expr) : string = + CodePrinter.genOak (Oak.mk_type_desc typ.desc) CodePrinter.emptyContext + |> CodePrinter.dump + +(* let oak = + Oak.Application + { + Oak.name = "foo"; + argument = + Oak.Tuple [{Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"}]; + } *) +(* Oak.Record + [ + {Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"}; + {Oak.name = "member"; value = Oak.Ident "Zigbar"}; + ] *) + +(* let _ = + CodePrinter.genOak oak CodePrinter.emptyContext + |> CodePrinter.dump |> Format.printf "%s\n" *) + +(* + Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/print_tast.ml +*) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 08837943b..08f0eb0ac 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -18,11 +18,14 @@ type constructorDoc = { items: constructorPayload option; } +type valueSignature = {parameters: string list; returnType: string} + type source = {filepath: string; line: int; col: int} type docItemDetail = | Record of {fieldDocs: fieldDoc list} | Variant of {constructorDocs: constructorDoc list} + | Signature of valueSignature type docItem = | Value of { @@ -31,6 +34,7 @@ type docItem = signature: string; name: string; deprecated: string option; + detail: docItemDetail option; source: source; } | Type of { @@ -147,6 +151,7 @@ let stringifyDetail ?(indentation = 0) (detail : docItemDetail) = ]) |> array) ); ] + | Signature {parameters; returnType} -> returnType let stringifySource ~indentation source = let open Protocol in @@ -160,7 +165,7 @@ let stringifySource ~indentation source = let rec stringifyDocItem ?(indentation = 0) ~originalEnv (item : docItem) = let open Protocol in match item with - | Value {id; docstring; signature; name; deprecated; source} -> + | Value {id; docstring; signature; name; deprecated; source; detail} -> stringifyObject ~startOnNewline:true ~indentation [ ("id", Some (wrapInQuotes id)); @@ -173,6 +178,11 @@ let rec stringifyDocItem ?(indentation = 0) ~originalEnv (item : docItem) = ("signature", Some (signature |> String.trim |> wrapInQuotes)); ("docstrings", Some (stringifyDocstrings docstring)); ("source", Some (stringifySource ~indentation:(indentation + 1) source)); + ( "detail", + match detail with + | None -> None + | Some detail -> + Some (stringifyDetail ~indentation:(indentation + 1) detail) ); ] | Type {id; docstring; signature; name; deprecated; detail; source} -> stringifyObject ~startOnNewline:true ~indentation @@ -310,6 +320,11 @@ let typeDetail typ ~env ~full = }) | _ -> None +let valueDetail (item : SharedTypes.Module.item) (typ : Types.type_expr) = + let s = Print_tast.print_type_expr typ in + Format.printf "%s\n" s; + Some (Signature {parameters = []; returnType = s}) + let makeId modulePath ~identifier = identifier :: modulePath |> List.rev |> SharedTypes.ident @@ -398,6 +413,7 @@ let extractDocs ~entryPointFile ~debug = ^ Shared.typeToString typ; name = item.name; deprecated = item.deprecated; + detail = valueDetail item typ; source; }) | Type (typ, _) -> From c88a9c9bc2786afe6dd63f1a5229e1041de2d2fe Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 8 Oct 2024 20:06:44 +0200 Subject: [PATCH 02/24] Print more variants of type_desc --- tools/bin/main.ml | 5 +++ tools/src/print_tast.ml | 84 +++++++++++++++++++++++++++++++++++++---- tools/src/tools.ml | 60 ++++++++++++++++++++++++++++- 3 files changed, 140 insertions(+), 9 deletions(-) diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 06be383b1..1183a2aa4 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -31,6 +31,11 @@ let version = Version.version let main () = match Sys.argv |> Array.to_list |> List.tl with + | "temp" :: rest -> ( + match rest with + | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) + | [path] -> logAndExit (Tools.dump ~entryPointFile:path ~debug:false) + | _ -> logAndExit (Error docHelp)) | "doc" :: rest -> ( match rest with | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 98380930e..2c01f2141 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -50,12 +50,65 @@ module Oak = struct | Tobject _ -> Ident "type_desc.Tobject" | Tfield _ -> Ident "type_desc.Tfield" | Tnil -> Ident "type_desc.Tnil" - | Tlink {desc} -> Ident "type_desc.Tlink" + | Tlink {desc} -> + Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} | Tsubst _ -> Ident "type_desc.Tsubst" - | Tvariant row_descr -> Ident "type_desc.Tvariant" + | Tvariant row_descr -> + Application + {name = "type_desc.Tvariant"; argument = mk_row_desc row_descr} | Tunivar _ -> Ident "type_desc.Tunivar" | Tpoly _ -> Ident "type_desc.Tpoly" | Tpackage _ -> Ident "type_desc.Tpackage" + + and mk_row_desc (row_desc : Types.row_desc) : oak = + let fields = + [ + { + name = "row_fields"; + value = + ( row_desc.row_fields + |> List.map (fun (label, row_field) -> + Tuple + [ + {name = "label"; value = Ident label}; + {name = "row_field"; value = mk_row_field row_field}; + ]) + |> fun ts -> List ts ); + }; + {name = "row_more"; value = mk_type_desc row_desc.row_more.desc}; + {name = "row_closed"; value = mk_bool row_desc.row_closed}; + {name = "row_fixed"; value = mk_bool row_desc.row_fixed}; + ] + in + match row_desc.row_name with + | None -> Record fields + | Some (path, ts) -> + Record + ({ + name = "row_name"; + value = + Tuple + [ + {name = "Path.t"; value = Ident (path_to_string path)}; + { + name = "fields"; + value = + List + (ts + |> List.map (fun (t : Types.type_expr) -> + mk_type_desc t.desc)); + }; + ]; + } + :: fields) + + and mk_row_field (row_field : Types.row_field) : oak = + match row_field with + | Rpresent _ -> Ident "row_field.Rpresent" + | Reither _ -> Ident "row_field.Reither" + | Rabsent -> Ident "row_field.Rabsent" + + and mk_bool (b : bool) : oak = if b then Ident "true" else Ident "false" end (** Transform the Oak types to string *) @@ -116,7 +169,7 @@ module CodePrinter = struct let sepNln ctx = {ctx with events = WriteLine :: ctx.events; current_line_column = 0} - + let sepSpace ctx = !-" " ctx let sepComma ctx = !-", " ctx let sepSemi ctx = !-"; " ctx let sepOpenT ctx = !-"(" ctx @@ -126,6 +179,7 @@ module CodePrinter = struct let sepOpenL ctx = !-"[" ctx let sepCloseL ctx = !-"]" ctx let sepEq ctx = !-" = " ctx + let wrapInParentheses f = sepOpenT +> f +> sepCloseT let indent ctx = let nextIdent = ctx.current_indent + ctx.indent_size in { @@ -197,14 +251,18 @@ module CodePrinter = struct in let long = !-(application.name) +> sepOpenT - +> indentAndNln (genOak application.argument) - +> sepNln +> sepCloseT + +> (match application.argument with + | Oak.List _ | Oak.Record _ -> genOak application.argument + | _ -> indentAndNln (genOak application.argument) +> sepNln) + +> sepCloseT in expressionFitsOnRestOfLine short long and genRecord (recordFields : Oak.namedField list) : appendEvents = let short = - sepOpenR +> col genNamedField sepSemi recordFields +> sepCloseR + sepOpenR +> sepSpace + +> col genNamedField sepSemi recordFields + +> sepSpace +> sepCloseR in let long = sepOpenR @@ -232,9 +290,19 @@ module CodePrinter = struct expressionFitsOnRestOfLine short long and genList (items : Oak.oak list) : appendEvents = - let short = sepOpenL +> col genOak sepSemi items +> sepCloseL in + let genItem = function + | Oak.Tuple _ as item -> wrapInParentheses (genOak item) + | item -> genOak item + in + let short = + match items with + | [] -> sepOpenL +> sepCloseL + | _ -> + sepOpenL +> sepSpace +> col genItem sepSemi items +> sepSpace + +> sepCloseL + in let long = - sepOpenL +> indentAndNln (col genOak sepNln items) +> sepNln +> sepCloseL + sepOpenL +> indentAndNln (col genItem sepNln items) +> sepNln +> sepCloseL in expressionFitsOnRestOfLine short long end diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 08f0eb0ac..7f9ff0306 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -322,7 +322,6 @@ let typeDetail typ ~env ~full = let valueDetail (item : SharedTypes.Module.item) (typ : Types.type_expr) = let s = Print_tast.print_type_expr typ in - Format.printf "%s\n" s; Some (Signature {parameters = []; returnType = s}) let makeId modulePath ~identifier = @@ -337,6 +336,65 @@ let getSource ~rootPath ({loc_start} : Location.t) = in {filepath; line = line + 1; col = col + 1} +let dump ~entryPointFile ~debug = + let path = + match Filename.is_relative entryPointFile with + | true -> Unix.realpath entryPointFile + | false -> entryPointFile + in + if debug then Printf.printf "extracting docs for %s\n" path; + let result = + match + FindFiles.isImplementation path = false + && FindFiles.isInterface path = false + with + | false -> ( + let path = + if FindFiles.isImplementation path then + let pathAsResi = + (path |> Filename.dirname) ^ "/" + ^ (path |> Filename.basename |> Filename.chop_extension) + ^ ".resi" + in + if Sys.file_exists pathAsResi then ( + if debug then + Printf.printf "preferring found resi file for impl: %s\n" + pathAsResi; + pathAsResi) + else path + else path + in + match Cmt.loadFullCmtFromPath ~path with + | None -> + Error + (Printf.sprintf + "error: failed to generate doc for %s, try to build the project" + path) + | Some full -> + let file = full.file in + let structure = file.structure in + let open SharedTypes in + let extractDocsForModule (structure : Module.structure) = + structure.items + |> List.filter_map (fun (item : Module.item) -> + match item.kind with + | Value typ -> ( + match valueDetail item typ with + | Some (Signature {returnType = rt}) -> Some rt + | _ -> None) + | _ -> None) + |> String.concat "\n" + in + let docs = extractDocsForModule structure in + Ok docs) + | true -> + Error + (Printf.sprintf + "error: failed to read %s, expected an .res or .resi file" path) + in + + result + let extractDocs ~entryPointFile ~debug = let path = match Filename.is_relative entryPointFile with From 4d596d8fc23479d92890130893aa28643078bcb8 Mon Sep 17 00:00:00 2001 From: nojaf Date: Tue, 8 Oct 2024 21:11:21 +0200 Subject: [PATCH 03/24] Initial signature dump --- tools/bin/main.ml | 5 -- tools/src/print_tast.ml | 35 ++++------- tools/src/tools.ml | 135 +++++++++++++++++++++------------------- 3 files changed, 81 insertions(+), 94 deletions(-) diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 1183a2aa4..06be383b1 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -31,11 +31,6 @@ let version = Version.version let main () = match Sys.argv |> Array.to_list |> List.tl with - | "temp" :: rest -> ( - match rest with - | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) - | [path] -> logAndExit (Tools.dump ~entryPointFile:path ~debug:false) - | _ -> logAndExit (Error docHelp)) | "doc" :: rest -> ( match rest with | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 2c01f2141..4850e5e4d 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -1,5 +1,3 @@ -(* *) - (** Transform the AST types to the more generic Oak format *) module Oak = struct type application = {name: string; argument: oak} @@ -20,7 +18,10 @@ module Oak = struct let rec mk_type_desc (desc : Types.type_desc) : oak = match desc with - | Tvar _ -> Ident "type_desc.Tvar" + | Tvar var -> ( + match var with + | None -> Application {name = "type_desc.Tvar"; argument = Ident "None"} + | Some s -> Application {name = "type_desc.Tvar"; argument = Ident s}) | Tarrow (_, t1, t2, _) -> Application { @@ -113,6 +114,13 @@ end (** Transform the Oak types to string *) module CodePrinter = struct + (** + The idea is that we capture events in a context type. + Doing this allows us to reason about the current state of the writer + and whether the next expression fits on the current line or not. + + *) + type writerEvents = | Write of string | WriteLine @@ -310,24 +318,3 @@ end let print_type_expr (typ : Types.type_expr) : string = CodePrinter.genOak (Oak.mk_type_desc typ.desc) CodePrinter.emptyContext |> CodePrinter.dump - -(* let oak = - Oak.Application - { - Oak.name = "foo"; - argument = - Oak.Tuple [{Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"}]; - } *) -(* Oak.Record - [ - {Oak.name = "foo"; value = Oak.Ident "baaaaaaaaaaaaaaaaar"}; - {Oak.name = "member"; value = Oak.Ident "Zigbar"}; - ] *) - -(* let _ = - CodePrinter.genOak oak CodePrinter.emptyContext - |> CodePrinter.dump |> Format.printf "%s\n" *) - -(* - Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/print_tast.ml -*) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 7f9ff0306..2b7258f57 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -18,7 +18,8 @@ type constructorDoc = { items: constructorPayload option; } -type valueSignature = {parameters: string list; returnType: string} +type typeDoc = {path: string; genericParameters: typeDoc list} +type valueSignature = {parameters: typeDoc list; returnType: typeDoc} type source = {filepath: string; line: int; col: int} @@ -108,6 +109,19 @@ let stringifyConstructorPayload ~indentation |> array) ); ] +let rec stringifyTypeDoc ~indentation (td : typeDoc) : string = + let open Protocol in + let ps = + match td.genericParameters with + | [] -> None + | ts -> + ts |> List.map (stringifyTypeDoc ~indentation:(indentation + 1)) + |> fun ts -> Some (array ts) + in + + stringifyObject ~indentation:(indentation + 1) + [("path", Some (wrapInQuotes td.path)); ("genericTypeParameters", ps)] + let stringifyDetail ?(indentation = 0) (detail : docItemDetail) = let open Protocol in match detail with @@ -151,7 +165,19 @@ let stringifyDetail ?(indentation = 0) (detail : docItemDetail) = ]) |> array) ); ] - | Signature {parameters; returnType} -> returnType + | Signature {parameters; returnType} -> + let ps = + match parameters with + | [] -> None + | ps -> + ps |> List.map (stringifyTypeDoc ~indentation:(indentation + 1)) + |> fun ps -> Some (array ps) + in + stringifyObject ~startOnNewline:false ~indentation + [ + ("parameters", ps); + ("returnType", Some (stringifyTypeDoc ~indentation returnType)); + ] let stringifySource ~indentation source = let open Protocol in @@ -320,9 +346,47 @@ let typeDetail typ ~env ~full = }) | _ -> None -let valueDetail (item : SharedTypes.Module.item) (typ : Types.type_expr) = - let s = Print_tast.print_type_expr typ in - Some (Signature {parameters = []; returnType = s}) +(* split a list into two parts all the items except the last one and the last item *) +let splitLast l = + let rec splitLast' acc = function + | [] -> failwith "splitLast: empty list" + | [x] -> (List.rev acc, x) + | x :: xs -> splitLast' (x :: acc) xs + in + splitLast' [] l + +let isFunction = function + | Path.Pident {name = "function$"} -> true + | _ -> false + +let valueDetail (typ : Types.type_expr) = + Printf.printf "%s\n" (Print_tast.print_type_expr typ); + let rec collectSignatureTypes (typ_desc : Types.type_desc) = + match typ_desc with + | Tlink t -> collectSignatureTypes t.desc + | Tconstr (path, [t; _], _) when isFunction path -> + collectSignatureTypes t.desc + | Tconstr (path, ts, _) -> ( + let p = Print_tast.Oak.path_to_string path in + match ts with + | [] -> [{path = p; genericParameters = []}] + | ts -> + let ts = + ts + |> List.concat_map (fun (t : Types.type_expr) -> + collectSignatureTypes t.desc) + in + [{path = p; genericParameters = ts}]) + | Tarrow (_, t1, t2, _) -> + collectSignatureTypes t1.desc @ collectSignatureTypes t2.desc + | Tvar None -> [{path = "_"; genericParameters = []}] + | _ -> [] + in + match collectSignatureTypes typ.desc with + | [] -> None + | ts -> + let parameters, returnType = splitLast ts in + Some (Signature {parameters; returnType}) let makeId modulePath ~identifier = identifier :: modulePath |> List.rev |> SharedTypes.ident @@ -336,65 +400,6 @@ let getSource ~rootPath ({loc_start} : Location.t) = in {filepath; line = line + 1; col = col + 1} -let dump ~entryPointFile ~debug = - let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile - in - if debug then Printf.printf "extracting docs for %s\n" path; - let result = - match - FindFiles.isImplementation path = false - && FindFiles.isInterface path = false - with - | false -> ( - let path = - if FindFiles.isImplementation path then - let pathAsResi = - (path |> Filename.dirname) ^ "/" - ^ (path |> Filename.basename |> Filename.chop_extension) - ^ ".resi" - in - if Sys.file_exists pathAsResi then ( - if debug then - Printf.printf "preferring found resi file for impl: %s\n" - pathAsResi; - pathAsResi) - else path - else path - in - match Cmt.loadFullCmtFromPath ~path with - | None -> - Error - (Printf.sprintf - "error: failed to generate doc for %s, try to build the project" - path) - | Some full -> - let file = full.file in - let structure = file.structure in - let open SharedTypes in - let extractDocsForModule (structure : Module.structure) = - structure.items - |> List.filter_map (fun (item : Module.item) -> - match item.kind with - | Value typ -> ( - match valueDetail item typ with - | Some (Signature {returnType = rt}) -> Some rt - | _ -> None) - | _ -> None) - |> String.concat "\n" - in - let docs = extractDocsForModule structure in - Ok docs) - | true -> - Error - (Printf.sprintf - "error: failed to read %s, expected an .res or .resi file" path) - in - - result - let extractDocs ~entryPointFile ~debug = let path = match Filename.is_relative entryPointFile with @@ -471,7 +476,7 @@ let extractDocs ~entryPointFile ~debug = ^ Shared.typeToString typ; name = item.name; deprecated = item.deprecated; - detail = valueDetail item typ; + detail = valueDetail typ; source; }) | Type (typ, _) -> From 312eee01eccf06a82850640830dfef2641c0432a Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 9 Oct 2024 10:46:04 +0200 Subject: [PATCH 04/24] Add dump command to view full file --- tools/bin/main.ml | 1 + tools/src/print_tast.ml | 134 +++++++++++++++++++++++++++++++++------- tools/src/tools.ml | 40 ++++++++++++ 3 files changed, 152 insertions(+), 23 deletions(-) diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 06be383b1..633b0b61b 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -31,6 +31,7 @@ let version = Version.version let main () = match Sys.argv |> Array.to_list |> List.tl with + | ["dump"; file] -> Tools.dump file |> logAndExit | "doc" :: rest -> ( match rest with | ["-h"] | ["--help"] -> logAndExit (Ok docHelp) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 4850e5e4d..e6c4ade87 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -1,3 +1,5 @@ +open Analysis + (** Transform the AST types to the more generic Oak format *) module Oak = struct type application = {name: string; argument: oak} @@ -10,12 +12,39 @@ module Oak = struct | Ident of string | Tuple of namedField list | List of oak list + | String of string + let mk_bool (b : bool) : oak = if b then Ident "true" else Ident "false" + + let mk_string_option (o : string option) : oak = + match o with + | None -> Ident "None" + | Some s -> Application {name = "Some"; argument = String s} + + let mk_string_list (items : string list) : oak = + List (items |> List.map (fun s -> String s)) + + let path_to_string path = + let buf = Buffer.create 64 in + let rec aux = function + | Path.Pident id -> Buffer.add_string buf (Ident.name id) + | Path.Pdot (p, s, _) -> + aux p; + Buffer.add_char buf '.'; + Buffer.add_string buf s + | Path.Papply (p1, p2) -> + aux p1; + Buffer.add_char buf '('; + aux p2; + Buffer.add_char buf ')' + in + aux path; + Buffer.contents buf - let rec path_to_string = function - | Path.Pident id -> Ident.name id - | Path.Pdot (p, s, _) -> path_to_string p ^ "." ^ s - | Path.Papply (p1, p2) -> path_to_string p1 ^ "(" ^ path_to_string p2 ^ ")" - + let mk_row_field (row_field : Types.row_field) : oak = + match row_field with + | Rpresent _ -> Ident "row_field.Rpresent" + | Reither _ -> Ident "row_field.Reither" + | Rabsent -> Ident "row_field.Rabsent" let rec mk_type_desc (desc : Types.type_desc) : oak = match desc with | Tvar var -> ( @@ -103,13 +132,57 @@ module Oak = struct } :: fields) - and mk_row_field (row_field : Types.row_field) : oak = - match row_field with - | Rpresent _ -> Ident "row_field.Rpresent" - | Reither _ -> Ident "row_field.Reither" - | Rabsent -> Ident "row_field.Rabsent" + let mk_package (package : SharedTypes.package) : oak = + Record + [ + { + name = "genericJsxModule"; + value = mk_string_option package.genericJsxModule; + }; + ] - and mk_bool (b : bool) : oak = if b then Ident "true" else Ident "false" + let mk_Uri (uri : Uri.t) : oak = String (Uri.toString uri) + + let mk_item (item : SharedTypes.Module.item) : oak = + let kind = + match item.kind with + | SharedTypes.Module.Value v -> + Application + {name = "SharedTypes.Module.Value"; argument = mk_type_desc v.desc} + | SharedTypes.Module.Type _ -> Ident "Type" + | SharedTypes.Module.Module _ -> Ident "Module" + in + Record + [ + {name = "kind"; value = kind}; + {name = "name"; value = String item.name}; + {name = "docstring"; value = mk_string_list item.docstring}; + {name = "deprecated"; value = mk_string_option item.deprecated}; + ] + + let mk_structure (structure : SharedTypes.Module.structure) : oak = + Record + [ + {name = "name"; value = String structure.name}; + {name = "docstring"; value = mk_string_list structure.docstring}; + {name = "items"; value = List (List.map mk_item structure.items)}; + {name = "deprecated"; value = mk_string_option structure.deprecated}; + ] + + let mk_file (file : SharedTypes.File.t) : oak = + Record + [ + {name = "uri"; value = mk_Uri file.uri}; + {name = "moduleName"; value = String file.moduleName}; + {name = "structure"; value = mk_structure file.structure}; + ] + + let mk_full (full : SharedTypes.full) : oak = + Record + [ + {name = "package"; value = mk_package full.package}; + {name = "file"; value = mk_file full.file}; + ] end (** Transform the Oak types to string *) @@ -231,23 +304,31 @@ module CodePrinter = struct (** Fold all the events in context into text *) let dump (ctx : context) = - let addSpaces n = String.make n ' ' in + let buf = Buffer.create 1024 in + let addSpaces n = Buffer.add_string buf (String.make n ' ') in List.fold_right - (fun event (acc, current_indent) -> + (fun event current_indent -> match event with - | Write str -> (acc ^ str, current_indent) - | WriteLine -> (acc ^ "\n" ^ addSpaces current_indent, current_indent) - | IndentBy n -> (acc, current_indent + n) - | UnindentBy n -> (acc, current_indent - n)) - ctx.events ("", 0) - |> fst + | Write str -> + Buffer.add_string buf str; + current_indent + | WriteLine -> + Buffer.add_char buf '\n'; + addSpaces current_indent; + current_indent + | IndentBy n -> current_indent + n + | UnindentBy n -> current_indent - n) + ctx.events ctx.current_indent + |> ignore; + Buffer.contents buf let rec genOak (oak : Oak.oak) : appendEvents = match oak with | Oak.Application application -> genApplication application | Oak.Record record -> genRecord record | Oak.Ident ident -> genIdent ident + | Oak.String str -> !-(Format.sprintf "\"%s\"" str) | Oak.Tuple ts -> genTuple ts | Oak.List xs -> genList xs @@ -268,9 +349,12 @@ module CodePrinter = struct and genRecord (recordFields : Oak.namedField list) : appendEvents = let short = - sepOpenR +> sepSpace - +> col genNamedField sepSemi recordFields - +> sepSpace +> sepCloseR + match recordFields with + | [] -> sepOpenR +> sepCloseR + | fields -> + sepOpenR +> sepSpace + +> col genNamedField sepSemi fields + +> sepSpace +> sepCloseR in let long = sepOpenR @@ -292,7 +376,7 @@ module CodePrinter = struct !-(field.name) +> sepEq +> match field.value with - | Oak.List _ -> genOak field.value + | Oak.List _ | Oak.Record _ -> genOak field.value | _ -> indentAndNln (genOak field.value) in expressionFitsOnRestOfLine short long @@ -318,3 +402,7 @@ end let print_type_expr (typ : Types.type_expr) : string = CodePrinter.genOak (Oak.mk_type_desc typ.desc) CodePrinter.emptyContext |> CodePrinter.dump + +let print_full (full : SharedTypes.full) : string = + CodePrinter.genOak (Oak.mk_full full) CodePrinter.emptyContext + |> CodePrinter.dump diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 2b7258f57..3d8335c9f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -640,3 +640,43 @@ let extractEmbedded ~extensionPoints ~filename = ("loc", Some (Analysis.Utils.cmtLocToRange loc |> stringifyRange)); ]) |> List.rev |> array + +let dump entryPointFile = + let path = + match Filename.is_relative entryPointFile with + | true -> Unix.realpath entryPointFile + | false -> entryPointFile + in + let result = + match + FindFiles.isImplementation path = false + && FindFiles.isInterface path = false + with + | false -> ( + let path = + if FindFiles.isImplementation path then + let pathAsResi = + (path |> Filename.dirname) ^ "/" + ^ (path |> Filename.basename |> Filename.chop_extension) + ^ ".resi" + in + if Sys.file_exists pathAsResi then ( + Printf.printf "preferring found resi file for impl: %s\n" pathAsResi; + pathAsResi) + else path + else path + in + match Cmt.loadFullCmtFromPath ~path with + | None -> + Error + (Printf.sprintf + "error: failed to generate doc for %s, try to build the project" + path) + | Some full -> Ok (Print_tast.print_full full)) + | true -> + Error + (Printf.sprintf + "error: failed to read %s, expected an .res or .resi file" path) + in + + result From 6f3e7fd5e4e562f03e322a4c88b1b8abb909c1b0 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 9 Oct 2024 11:16:49 +0200 Subject: [PATCH 05/24] Try CPS --- tools/src/print_tast.ml | 168 +++++++++++++++++++++------------------- 1 file changed, 90 insertions(+), 78 deletions(-) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index e6c4ade87..3e6be3392 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -45,92 +45,104 @@ module Oak = struct | Rpresent _ -> Ident "row_field.Rpresent" | Reither _ -> Ident "row_field.Reither" | Rabsent -> Ident "row_field.Rabsent" - let rec mk_type_desc (desc : Types.type_desc) : oak = + + let rec mk_type_desc_cps (desc : Types.type_desc) (continuation : oak -> oak) + : oak = match desc with - | Tvar var -> ( - match var with - | None -> Application {name = "type_desc.Tvar"; argument = Ident "None"} - | Some s -> Application {name = "type_desc.Tvar"; argument = Ident s}) + | Tvar var -> + continuation + (Application {name = "type_desc.Tvar"; argument = mk_string_option var}) | Tarrow (_, t1, t2, _) -> - Application - { - name = "type_desc.Tarrow"; - argument = - Tuple - [ - {name = "t1"; value = mk_type_desc t1.desc}; - {name = "t2"; value = mk_type_desc t2.desc}; - ]; - } - | Ttuple _ -> Ident "type_desc.Ttuple" + mk_type_desc_cps t1.desc (fun t1_result -> + mk_type_desc_cps t2.desc (fun t2_result -> + continuation + (Application + { + name = "type_desc.Tarrow"; + argument = + Tuple + [ + {name = "t1"; value = t1_result}; + {name = "t2"; value = t2_result}; + ]; + }))) + | Ttuple _ -> continuation (Ident "type_desc.Ttuple") | Tconstr (path, ts, _) -> let ts = - ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) + List.map + (fun (t : Types.type_expr) -> mk_type_desc_cps t.desc (fun t -> t)) + ts in - Application - { - name = "type_desc.Tconstr"; - argument = - Tuple - [ - {name = "path"; value = Ident (path_to_string path)}; - {name = "ts"; value = List ts}; - ]; - } - | Tobject _ -> Ident "type_desc.Tobject" - | Tfield _ -> Ident "type_desc.Tfield" - | Tnil -> Ident "type_desc.Tnil" + continuation + (Application + { + name = "type_desc.Tconstr"; + argument = + Tuple + [ + {name = "path"; value = Ident (path_to_string path)}; + {name = "ts"; value = List ts}; + ]; + }) + | Tobject _ -> continuation (Ident "type_desc.Tobject") + | Tfield _ -> continuation (Ident "type_desc.Tfield") + | Tnil -> continuation (Ident "type_desc.Tnil") | Tlink {desc} -> - Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} - | Tsubst _ -> Ident "type_desc.Tsubst" + mk_type_desc_cps desc (fun result -> + continuation + (Application {name = "type_desc.Tlink"; argument = result})) + | Tsubst _ -> continuation (Ident "type_desc.Tsubst") | Tvariant row_descr -> - Application - {name = "type_desc.Tvariant"; argument = mk_row_desc row_descr} - | Tunivar _ -> Ident "type_desc.Tunivar" - | Tpoly _ -> Ident "type_desc.Tpoly" - | Tpackage _ -> Ident "type_desc.Tpackage" - - and mk_row_desc (row_desc : Types.row_desc) : oak = - let fields = - [ - { - name = "row_fields"; - value = - ( row_desc.row_fields - |> List.map (fun (label, row_field) -> - Tuple - [ - {name = "label"; value = Ident label}; - {name = "row_field"; value = mk_row_field row_field}; - ]) - |> fun ts -> List ts ); - }; - {name = "row_more"; value = mk_type_desc row_desc.row_more.desc}; - {name = "row_closed"; value = mk_bool row_desc.row_closed}; - {name = "row_fixed"; value = mk_bool row_desc.row_fixed}; - ] - in - match row_desc.row_name with - | None -> Record fields - | Some (path, ts) -> - Record - ({ - name = "row_name"; + continuation + (Application {name = "type_desc.Tvariant"; argument = Ident "row_descr"}) + | Tunivar _ -> continuation (Ident "type_desc.Tunivar") + | Tpoly _ -> continuation (Ident "type_desc.Tpoly") + | Tpackage _ -> continuation (Ident "type_desc.Tpackage") + + let mk_type_desc (desc : Types.type_desc) : oak = + mk_type_desc_cps desc (fun result -> result) + + (* and mk_row_desc (row_desc : Types.row_desc) : oak = + let fields = + [ + { + name = "row_fields"; value = - Tuple - [ - {name = "Path.t"; value = Ident (path_to_string path)}; - { - name = "fields"; - value = - List - (ts - |> List.map (fun (t : Types.type_expr) -> - mk_type_desc t.desc)); - }; - ]; - } - :: fields) + ( row_desc.row_fields + |> List.map (fun (label, row_field) -> + Tuple + [ + {name = "label"; value = Ident label}; + {name = "row_field"; value = mk_row_field row_field}; + ]) + |> fun ts -> List ts ); + }; + {name = "row_more"; value = mk_type_desc row_desc.row_more.desc}; + {name = "row_closed"; value = mk_bool row_desc.row_closed}; + {name = "row_fixed"; value = mk_bool row_desc.row_fixed}; + ] + in + match row_desc.row_name with + | None -> Record fields + | Some (path, ts) -> + Record + ({ + name = "row_name"; + value = + Tuple + [ + {name = "Path.t"; value = Ident (path_to_string path)}; + { + name = "fields"; + value = + List + (ts + |> List.map (fun (t : Types.type_expr) -> + mk_type_desc t.desc)); + }; + ]; + } + :: fields) *) let mk_package (package : SharedTypes.package) : oak = Record From 765a49f8ab0a30e30226b4f66e81e9f12de6d2cd Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 9 Oct 2024 13:00:00 +0200 Subject: [PATCH 06/24] Revert "Try CPS" This reverts commit 6f3e7fd5e4e562f03e322a4c88b1b8abb909c1b0. --- tools/src/print_tast.ml | 168 +++++++++++++++++++--------------------- 1 file changed, 78 insertions(+), 90 deletions(-) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 3e6be3392..e6c4ade87 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -45,104 +45,92 @@ module Oak = struct | Rpresent _ -> Ident "row_field.Rpresent" | Reither _ -> Ident "row_field.Reither" | Rabsent -> Ident "row_field.Rabsent" - - let rec mk_type_desc_cps (desc : Types.type_desc) (continuation : oak -> oak) - : oak = + let rec mk_type_desc (desc : Types.type_desc) : oak = match desc with - | Tvar var -> - continuation - (Application {name = "type_desc.Tvar"; argument = mk_string_option var}) + | Tvar var -> ( + match var with + | None -> Application {name = "type_desc.Tvar"; argument = Ident "None"} + | Some s -> Application {name = "type_desc.Tvar"; argument = Ident s}) | Tarrow (_, t1, t2, _) -> - mk_type_desc_cps t1.desc (fun t1_result -> - mk_type_desc_cps t2.desc (fun t2_result -> - continuation - (Application - { - name = "type_desc.Tarrow"; - argument = - Tuple - [ - {name = "t1"; value = t1_result}; - {name = "t2"; value = t2_result}; - ]; - }))) - | Ttuple _ -> continuation (Ident "type_desc.Ttuple") + Application + { + name = "type_desc.Tarrow"; + argument = + Tuple + [ + {name = "t1"; value = mk_type_desc t1.desc}; + {name = "t2"; value = mk_type_desc t2.desc}; + ]; + } + | Ttuple _ -> Ident "type_desc.Ttuple" | Tconstr (path, ts, _) -> let ts = - List.map - (fun (t : Types.type_expr) -> mk_type_desc_cps t.desc (fun t -> t)) - ts + ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) in - continuation - (Application - { - name = "type_desc.Tconstr"; - argument = - Tuple - [ - {name = "path"; value = Ident (path_to_string path)}; - {name = "ts"; value = List ts}; - ]; - }) - | Tobject _ -> continuation (Ident "type_desc.Tobject") - | Tfield _ -> continuation (Ident "type_desc.Tfield") - | Tnil -> continuation (Ident "type_desc.Tnil") + Application + { + name = "type_desc.Tconstr"; + argument = + Tuple + [ + {name = "path"; value = Ident (path_to_string path)}; + {name = "ts"; value = List ts}; + ]; + } + | Tobject _ -> Ident "type_desc.Tobject" + | Tfield _ -> Ident "type_desc.Tfield" + | Tnil -> Ident "type_desc.Tnil" | Tlink {desc} -> - mk_type_desc_cps desc (fun result -> - continuation - (Application {name = "type_desc.Tlink"; argument = result})) - | Tsubst _ -> continuation (Ident "type_desc.Tsubst") + Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} + | Tsubst _ -> Ident "type_desc.Tsubst" | Tvariant row_descr -> - continuation - (Application {name = "type_desc.Tvariant"; argument = Ident "row_descr"}) - | Tunivar _ -> continuation (Ident "type_desc.Tunivar") - | Tpoly _ -> continuation (Ident "type_desc.Tpoly") - | Tpackage _ -> continuation (Ident "type_desc.Tpackage") - - let mk_type_desc (desc : Types.type_desc) : oak = - mk_type_desc_cps desc (fun result -> result) - - (* and mk_row_desc (row_desc : Types.row_desc) : oak = - let fields = - [ - { - name = "row_fields"; + Application + {name = "type_desc.Tvariant"; argument = mk_row_desc row_descr} + | Tunivar _ -> Ident "type_desc.Tunivar" + | Tpoly _ -> Ident "type_desc.Tpoly" + | Tpackage _ -> Ident "type_desc.Tpackage" + + and mk_row_desc (row_desc : Types.row_desc) : oak = + let fields = + [ + { + name = "row_fields"; + value = + ( row_desc.row_fields + |> List.map (fun (label, row_field) -> + Tuple + [ + {name = "label"; value = Ident label}; + {name = "row_field"; value = mk_row_field row_field}; + ]) + |> fun ts -> List ts ); + }; + {name = "row_more"; value = mk_type_desc row_desc.row_more.desc}; + {name = "row_closed"; value = mk_bool row_desc.row_closed}; + {name = "row_fixed"; value = mk_bool row_desc.row_fixed}; + ] + in + match row_desc.row_name with + | None -> Record fields + | Some (path, ts) -> + Record + ({ + name = "row_name"; value = - ( row_desc.row_fields - |> List.map (fun (label, row_field) -> - Tuple - [ - {name = "label"; value = Ident label}; - {name = "row_field"; value = mk_row_field row_field}; - ]) - |> fun ts -> List ts ); - }; - {name = "row_more"; value = mk_type_desc row_desc.row_more.desc}; - {name = "row_closed"; value = mk_bool row_desc.row_closed}; - {name = "row_fixed"; value = mk_bool row_desc.row_fixed}; - ] - in - match row_desc.row_name with - | None -> Record fields - | Some (path, ts) -> - Record - ({ - name = "row_name"; - value = - Tuple - [ - {name = "Path.t"; value = Ident (path_to_string path)}; - { - name = "fields"; - value = - List - (ts - |> List.map (fun (t : Types.type_expr) -> - mk_type_desc t.desc)); - }; - ]; - } - :: fields) *) + Tuple + [ + {name = "Path.t"; value = Ident (path_to_string path)}; + { + name = "fields"; + value = + List + (ts + |> List.map (fun (t : Types.type_expr) -> + mk_type_desc t.desc)); + }; + ]; + } + :: fields) let mk_package (package : SharedTypes.package) : oak = Record From 46ab52f61de3587825e48781d57a02e7a5b94e1a Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 9 Oct 2024 13:21:07 +0200 Subject: [PATCH 07/24] Print name_of_type_desc --- tools/src/print_tast.ml | 46 ++++++++++++++++++++++++++++------------- 1 file changed, 32 insertions(+), 14 deletions(-) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index e6c4ade87..db826d06a 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -45,24 +45,32 @@ module Oak = struct | Rpresent _ -> Ident "row_field.Rpresent" | Reither _ -> Ident "row_field.Reither" | Rabsent -> Ident "row_field.Rabsent" + + let name_of_type_desc (desc : Types.type_desc) = + match desc with + | Tvar _ -> "Tvar" + | Tarrow _ -> "Tarrow" + | Ttuple _ -> "Ttuple" + | Tconstr _ -> "Tconstr" + | Tobject _ -> "Tobject" + | Tfield _ -> "Tfield" + | Tnil -> "Tnil" + | Tlink _ -> "Tlink" + | Tsubst _ -> "Tsubst" + | Tvariant _ -> "Tvariant" + | Tunivar _ -> "Tunivar" + | Tpoly _ -> "Tpoly" + | Tpackage _ -> "Tpackage" + let rec mk_type_desc (desc : Types.type_desc) : oak = + Printf.printf "entering mk_type_desc for %s\n" (name_of_type_desc desc); match desc with + | Tlink {desc} -> + Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} | Tvar var -> ( match var with | None -> Application {name = "type_desc.Tvar"; argument = Ident "None"} | Some s -> Application {name = "type_desc.Tvar"; argument = Ident s}) - | Tarrow (_, t1, t2, _) -> - Application - { - name = "type_desc.Tarrow"; - argument = - Tuple - [ - {name = "t1"; value = mk_type_desc t1.desc}; - {name = "t2"; value = mk_type_desc t2.desc}; - ]; - } - | Ttuple _ -> Ident "type_desc.Ttuple" | Tconstr (path, ts, _) -> let ts = ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) @@ -77,11 +85,21 @@ module Oak = struct {name = "ts"; value = List ts}; ]; } + | Tarrow (_, t1, t2, _) -> + Application + { + name = "type_desc.Tarrow"; + argument = + Tuple + [ + {name = "t1"; value = mk_type_desc t1.desc}; + {name = "t2"; value = mk_type_desc t2.desc}; + ]; + } + | Ttuple _ -> Ident "type_desc.Ttuple" | Tobject _ -> Ident "type_desc.Tobject" | Tfield _ -> Ident "type_desc.Tfield" | Tnil -> Ident "type_desc.Tnil" - | Tlink {desc} -> - Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} | Tsubst _ -> Ident "type_desc.Tsubst" | Tvariant row_descr -> Application From b6ae20c846ac61701195406c29e6481e7fafcada Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Oct 2024 10:31:09 +0200 Subject: [PATCH 08/24] Extract printer from tast transformer --- tools/src/prettier_printer.ml | 280 ++++++++++++++++++++++++++++++++++ tools/src/print_tast.ml | 254 +----------------------------- tools/src/tools.ml | 2 +- 3 files changed, 288 insertions(+), 248 deletions(-) create mode 100644 tools/src/prettier_printer.ml diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml new file mode 100644 index 000000000..3b57c0fd5 --- /dev/null +++ b/tools/src/prettier_printer.ml @@ -0,0 +1,280 @@ +(* open Analysis *) + +module DSL = struct + type application = {name: string; argument: oak} + + and namedField = {name: string; value: oak} + + and oak = + | Application of application + | Record of namedField list + | Ident of string + | Tuple of namedField list + | List of oak list + | String of string +end + +(** Transform the Oak types to string *) +module CodePrinter = struct + open DSL + + (** + The idea is that we capture events in a context type. + Doing this allows us to reason about the current state of the writer + and whether the next expression fits on the current line or not. + + *) + + type writerEvents = + | Write of string + | WriteLine + | IndentBy of int + | UnindentBy of int + + type context = { + indent_size: int; + max_line_length: int; + current_indent: int; + current_line_column: int; + events: writerEvents list; + line_count: int; + nesting_level: int; + } + + type appendEvents = context -> context + + let emptyContext = + { + indent_size = 2; + max_line_length = 80; + current_indent = 0; + current_line_column = 0; + events = []; + line_count = 0; + nesting_level = 0; + } + + (** Fold all the events in context into text *) + let dump (ctx : context) = + let buf = Buffer.create 1024 in + let addSpaces n = Buffer.add_string buf (String.make n ' ') in + + List.fold_right + (fun event current_indent -> + match event with + | Write str -> + Buffer.add_string buf str; + current_indent + | WriteLine -> + Buffer.add_char buf '\n'; + addSpaces current_indent; + current_indent + | IndentBy n -> current_indent + n + | UnindentBy n -> current_indent - n) + ctx.events ctx.current_indent + |> ignore; + Buffer.contents buf + + let debug_context (ctx : context) = + Format.printf "Current indent: %d, Current line: %d, Events: %d\n" + ctx.current_indent ctx.line_count (List.length ctx.events); + ctx + + let increase_nesting ctx = {ctx with nesting_level = ctx.nesting_level + 1} + + let decrease_nesting ctx = + {ctx with nesting_level = max 0 (ctx.nesting_level - 1)} + + (* Type representing the writer context during code printing + + - [indent_size] is the configured indentation size, typically 2 + - [current_indent] is the current indentation size + - [current_line_column] is the characters written on the current line + - [events] is the write events in reverse order, head event is last written + *) + + let id x = x + + (** add a write event to the context *) + let ( !- ) str ctx = + { + ctx with + events = Write str :: ctx.events; + current_line_column = ctx.current_line_column + String.length str; + } + + (** compose two context transforming functions *) + let ( +> ) f g ctx = g (f ctx) + + let sepNln ctx = + { + ctx with + events = WriteLine :: ctx.events; + current_line_column = ctx.current_indent; + line_count = ctx.line_count + 1; + } + let sepSpace ctx = !-" " ctx + let sepComma ctx = !-", " ctx + let sepSemi ctx = !-"; " ctx + let sepOpenT ctx = !-"(" ctx + let sepCloseT ctx = !-")" ctx + let sepOpenR ctx = !-"{" ctx + let sepCloseR ctx = !-"}" ctx + let sepOpenL ctx = !-"[" ctx + let sepCloseL ctx = !-"]" ctx + let sepEq ctx = !-" = " ctx + let wrapInParentheses f = sepOpenT +> f +> sepCloseT + let indent ctx = + let nextIdent = ctx.current_indent + ctx.indent_size in + { + ctx with + current_indent = nextIdent; + current_line_column = nextIdent; + events = IndentBy ctx.indent_size :: ctx.events; + } + let unindent ctx = + let nextIdent = ctx.current_indent - ctx.indent_size in + { + ctx with + current_indent = nextIdent; + current_line_column = nextIdent; + events = UnindentBy ctx.indent_size :: ctx.events; + } + + let indentAndNln f = indent +> sepNln +> f +> unindent + + let col (f : 't -> appendEvents) (intertwine : appendEvents) items ctx = + let rec visit items ctx = + match items with + | [] -> ctx + | [item] -> f item ctx + | item :: rest -> + let ctx' = (f item +> intertwine) ctx in + visit rest ctx' + in + visit items ctx + + let expressionFitsOnRestOfLine (f : appendEvents) (fallback : appendEvents) + (ctx : context) = + (* create a short context and check if the expression fits on the current line *) + let shortCtx = f ctx in + if + ctx.line_count == shortCtx.line_count + && shortCtx.current_line_column <= ctx.max_line_length + then shortCtx + else fallback ctx + + let rec genOak (oak : oak) : appendEvents = + match oak with + | Application application -> genApplication application + | Record record -> genRecord record + | Ident ident -> genIdent ident + | String str -> !-(Format.sprintf "\"%s\"" str) + | Tuple ts -> genTuple ts + | List xs -> genList xs + + and genApplication (application : application) : appendEvents = + let short = + !-(application.name) +> sepOpenT + +> genOak application.argument + +> sepCloseT + in + let long = + !-(application.name) +> sepOpenT + +> (match application.argument with + | List _ | Record _ -> genOak application.argument + | _ -> indentAndNln (genOak application.argument) +> sepNln) + +> sepCloseT + in + expressionFitsOnRestOfLine short long + + and genRecord (recordFields : namedField list) : appendEvents = + let short = + match recordFields with + | [] -> sepOpenR +> sepCloseR + | fields -> + sepOpenR +> sepSpace + +> col genNamedField sepSemi fields + +> sepSpace +> sepCloseR + in + let long = + sepOpenR + +> indentAndNln (col genNamedField sepNln recordFields) + +> sepNln +> sepCloseR + in + expressionFitsOnRestOfLine short long + + and genTuple (oaks : namedField list) : appendEvents = + let short = col genNamedField sepComma oaks in + let long = col genNamedField sepNln oaks in + expressionFitsOnRestOfLine short long + + and genIdent (ident : string) : appendEvents = !-ident + + and genNamedField (field : namedField) : appendEvents = + let short = !-(field.name) +> sepEq +> genOak field.value in + let long = + !-(field.name) +> sepEq + +> + match field.value with + | List _ | Record _ -> genOak field.value + | _ -> indentAndNln (genOak field.value) + in + expressionFitsOnRestOfLine short long + + and genList (items : oak list) : appendEvents = + let genItem = function + | Tuple _ as item -> wrapInParentheses (genOak item) + | item -> genOak item + in + let short = + match items with + | [] -> sepOpenL +> sepCloseL + | _ -> + sepOpenL +> sepSpace +> col genItem sepSemi items +> sepSpace + +> sepCloseL + in + let long = + sepOpenL +> indentAndNln (col genItem sepNln items) +> sepNln +> sepCloseL + in + expressionFitsOnRestOfLine short long +end + +open DSL + +let oak = + DSL.Record + [ + { + name = "zig"; + value = + DSL.Record + [ + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + {name = "member"; value = Ident "Zigbaaaaaaaaar"}; + ]; + }; + { + name = "roxas"; + value = + List + [ + Ident "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"; + Ident "meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"; + DSL.Record + [ + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + {name = "member"; value = Ident "Zigbaaaaaaaaar"}; + ]; + ]; + }; + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + ] + +(* let _ = + CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} + |> CodePrinter.dump |> Format.printf "%s\n" *) + +(* + Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/prettier_printer.ml +*) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index db826d06a..2f4955ef8 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -1,18 +1,8 @@ +open Prettier_printer +open DSL open Analysis -(** Transform the AST types to the more generic Oak format *) -module Oak = struct - type application = {name: string; argument: oak} - - and namedField = {name: string; value: oak} - - and oak = - | Application of application - | Record of namedField list - | Ident of string - | Tuple of namedField list - | List of oak list - | String of string +module Transform = struct let mk_bool (b : bool) : oak = if b then Ident "true" else Ident "false" let mk_string_option (o : string option) : oak = @@ -46,24 +36,7 @@ module Oak = struct | Reither _ -> Ident "row_field.Reither" | Rabsent -> Ident "row_field.Rabsent" - let name_of_type_desc (desc : Types.type_desc) = - match desc with - | Tvar _ -> "Tvar" - | Tarrow _ -> "Tarrow" - | Ttuple _ -> "Ttuple" - | Tconstr _ -> "Tconstr" - | Tobject _ -> "Tobject" - | Tfield _ -> "Tfield" - | Tnil -> "Tnil" - | Tlink _ -> "Tlink" - | Tsubst _ -> "Tsubst" - | Tvariant _ -> "Tvariant" - | Tunivar _ -> "Tunivar" - | Tpoly _ -> "Tpoly" - | Tpackage _ -> "Tpackage" - let rec mk_type_desc (desc : Types.type_desc) : oak = - Printf.printf "entering mk_type_desc for %s\n" (name_of_type_desc desc); match desc with | Tlink {desc} -> Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} @@ -172,8 +145,8 @@ module Oak = struct in Record [ - {name = "kind"; value = kind}; {name = "name"; value = String item.name}; + {name = "kind"; value = kind}; {name = "docstring"; value = mk_string_list item.docstring}; {name = "deprecated"; value = mk_string_option item.deprecated}; ] @@ -203,224 +176,11 @@ module Oak = struct ] end -(** Transform the Oak types to string *) -module CodePrinter = struct - (** - The idea is that we capture events in a context type. - Doing this allows us to reason about the current state of the writer - and whether the next expression fits on the current line or not. - - *) - - type writerEvents = - | Write of string - | WriteLine - | IndentBy of int - | UnindentBy of int - - type context = { - indent_size: int; - max_line_length: int; - current_indent: int; - current_line_column: int; - events: writerEvents list; - } - - let countLines (ctx : context) = - ctx.events - |> List.filter (fun event -> - match event with - | WriteLine -> true - | _ -> false) - |> List.length - - type appendEvents = context -> context - - let emptyContext = - { - indent_size = 2; - max_line_length = 80; - current_indent = 0; - current_line_column = 0; - events = []; - } - - (* Type representing the writer context during code printing - - - [indent_size] is the configured indentation size, typically 2 - - [current_indent] is the current indentation size - - [current_line_column] is the characters written on the current line - - [events] is the write events in reverse order, head event is last written - *) - - let id x = x - - (** add a write event to the context *) - let ( !- ) str ctx = - { - ctx with - events = Write str :: ctx.events; - current_line_column = ctx.current_line_column + String.length str; - } - - (** compose two context transforming functions *) - let ( +> ) f g ctx = g (f ctx) - - let sepNln ctx = - {ctx with events = WriteLine :: ctx.events; current_line_column = 0} - let sepSpace ctx = !-" " ctx - let sepComma ctx = !-", " ctx - let sepSemi ctx = !-"; " ctx - let sepOpenT ctx = !-"(" ctx - let sepCloseT ctx = !-")" ctx - let sepOpenR ctx = !-"{" ctx - let sepCloseR ctx = !-"}" ctx - let sepOpenL ctx = !-"[" ctx - let sepCloseL ctx = !-"]" ctx - let sepEq ctx = !-" = " ctx - let wrapInParentheses f = sepOpenT +> f +> sepCloseT - let indent ctx = - let nextIdent = ctx.current_indent + ctx.indent_size in - { - ctx with - current_indent = nextIdent; - current_line_column = nextIdent; - events = IndentBy ctx.indent_size :: ctx.events; - } - let unindent ctx = - let nextIdent = ctx.current_indent - ctx.indent_size in - { - ctx with - current_indent = nextIdent; - current_line_column = nextIdent; - events = UnindentBy ctx.indent_size :: ctx.events; - } - - let indentAndNln f = indent +> sepNln +> f +> unindent - - let col (f : 't -> appendEvents) (intertwine : appendEvents) items ctx = - let rec visit items ctx = - match items with - | [] -> ctx - | [item] -> f item ctx - | item :: rest -> - let ctx' = (f item +> intertwine) ctx in - visit rest ctx' - in - visit items ctx - - let expressionFitsOnRestOfLine (f : appendEvents) (fallback : appendEvents) - (ctx : context) = - let current_line_count = countLines ctx in - let shortCtx = f ctx in - let nextLineCount = countLines shortCtx in - if - current_line_count == nextLineCount - && shortCtx.current_line_column <= ctx.max_line_length - then shortCtx - else fallback ctx - - (** Fold all the events in context into text *) - let dump (ctx : context) = - let buf = Buffer.create 1024 in - let addSpaces n = Buffer.add_string buf (String.make n ' ') in - - List.fold_right - (fun event current_indent -> - match event with - | Write str -> - Buffer.add_string buf str; - current_indent - | WriteLine -> - Buffer.add_char buf '\n'; - addSpaces current_indent; - current_indent - | IndentBy n -> current_indent + n - | UnindentBy n -> current_indent - n) - ctx.events ctx.current_indent - |> ignore; - Buffer.contents buf - - let rec genOak (oak : Oak.oak) : appendEvents = - match oak with - | Oak.Application application -> genApplication application - | Oak.Record record -> genRecord record - | Oak.Ident ident -> genIdent ident - | Oak.String str -> !-(Format.sprintf "\"%s\"" str) - | Oak.Tuple ts -> genTuple ts - | Oak.List xs -> genList xs - - and genApplication (application : Oak.application) : appendEvents = - let short = - !-(application.name) +> sepOpenT - +> genOak application.argument - +> sepCloseT - in - let long = - !-(application.name) +> sepOpenT - +> (match application.argument with - | Oak.List _ | Oak.Record _ -> genOak application.argument - | _ -> indentAndNln (genOak application.argument) +> sepNln) - +> sepCloseT - in - expressionFitsOnRestOfLine short long - - and genRecord (recordFields : Oak.namedField list) : appendEvents = - let short = - match recordFields with - | [] -> sepOpenR +> sepCloseR - | fields -> - sepOpenR +> sepSpace - +> col genNamedField sepSemi fields - +> sepSpace +> sepCloseR - in - let long = - sepOpenR - +> indentAndNln (col genNamedField sepNln recordFields) - +> sepNln +> sepCloseR - in - expressionFitsOnRestOfLine short long - - and genTuple (oaks : Oak.namedField list) : appendEvents = - let short = col genNamedField sepComma oaks in - let long = col genNamedField sepNln oaks in - expressionFitsOnRestOfLine short long - - and genIdent (ident : string) : appendEvents = !-ident - - and genNamedField (field : Oak.namedField) : appendEvents = - let short = !-(field.name) +> sepEq +> genOak field.value in - let long = - !-(field.name) +> sepEq - +> - match field.value with - | Oak.List _ | Oak.Record _ -> genOak field.value - | _ -> indentAndNln (genOak field.value) - in - expressionFitsOnRestOfLine short long - - and genList (items : Oak.oak list) : appendEvents = - let genItem = function - | Oak.Tuple _ as item -> wrapInParentheses (genOak item) - | item -> genOak item - in - let short = - match items with - | [] -> sepOpenL +> sepCloseL - | _ -> - sepOpenL +> sepSpace +> col genItem sepSemi items +> sepSpace - +> sepCloseL - in - let long = - sepOpenL +> indentAndNln (col genItem sepNln items) +> sepNln +> sepCloseL - in - expressionFitsOnRestOfLine short long -end - let print_type_expr (typ : Types.type_expr) : string = - CodePrinter.genOak (Oak.mk_type_desc typ.desc) CodePrinter.emptyContext + CodePrinter.genOak (Transform.mk_type_desc typ.desc) CodePrinter.emptyContext |> CodePrinter.dump let print_full (full : SharedTypes.full) : string = - CodePrinter.genOak (Oak.mk_full full) CodePrinter.emptyContext + CodePrinter.genOak (Transform.mk_full full) CodePrinter.emptyContext + |> CodePrinter.debug_context |> CodePrinter.dump diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 3d8335c9f..a784a6863 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -367,7 +367,7 @@ let valueDetail (typ : Types.type_expr) = | Tconstr (path, [t; _], _) when isFunction path -> collectSignatureTypes t.desc | Tconstr (path, ts, _) -> ( - let p = Print_tast.Oak.path_to_string path in + let p = Print_tast.Transform.path_to_string path in match ts with | [] -> [{path = p; genericParameters = []}] | ts -> From 30f74542cac27dc2e4f3330b189779879951ef7d Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Oct 2024 13:59:57 +0200 Subject: [PATCH 09/24] Fix performance of expressionFitsOnRestOfLine --- tools/src/prettier_printer.ml | 100 +++++++++++++++++++++++----------- tools/src/print_tast.ml | 1 - 2 files changed, 67 insertions(+), 34 deletions(-) diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index 3b57c0fd5..c1a135b8a 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -22,7 +22,6 @@ module CodePrinter = struct The idea is that we capture events in a context type. Doing this allows us to reason about the current state of the writer and whether the next expression fits on the current line or not. - *) type writerEvents = @@ -31,14 +30,26 @@ module CodePrinter = struct | IndentBy of int | UnindentBy of int + type writerMode = Standard | TrySingleLine | ConfirmedMultiline + + (* Type representing the writer context during code printing + + - [indent_size] is the configured indentation size, typically 2 + - [max_line_length] is the maximum line length before we break the line + - [current_indent] is the current indentation size + - [current_line_column] is the characters written on the current line + - [line_count] is the number of lines written + - [events] is the write events in reverse order, head event is last written + - [mode] is the current writer mode (Standard or SingleLine) + *) type context = { indent_size: int; max_line_length: int; current_indent: int; current_line_column: int; - events: writerEvents list; line_count: int; - nesting_level: int; + events: writerEvents list; + mode: writerMode; } type appendEvents = context -> context @@ -46,12 +57,12 @@ module CodePrinter = struct let emptyContext = { indent_size = 2; - max_line_length = 80; + max_line_length = 120; current_indent = 0; current_line_column = 0; - events = []; line_count = 0; - nesting_level = 0; + events = []; + mode = Standard; } (** Fold all the events in context into text *) @@ -76,22 +87,30 @@ module CodePrinter = struct Buffer.contents buf let debug_context (ctx : context) = - Format.printf "Current indent: %d, Current line: %d, Events: %d\n" - ctx.current_indent ctx.line_count (List.length ctx.events); + let mode = + match ctx.mode with + | Standard -> "Standard" + | TrySingleLine _ -> "TrySingleLine" + | ConfirmedMultiline -> "ConfirmedMultiline" + in + Format.printf + "Current indent: %d, Current column: %d, # Lines: %d Events: %d, Mode: %s\n" + ctx.current_indent ctx.current_line_column ctx.line_count + (List.length ctx.events) mode; ctx - let increase_nesting ctx = {ctx with nesting_level = ctx.nesting_level + 1} - - let decrease_nesting ctx = - {ctx with nesting_level = max 0 (ctx.nesting_level - 1)} - - (* Type representing the writer context during code printing - - - [indent_size] is the configured indentation size, typically 2 - - [current_indent] is the current indentation size - - [current_line_column] is the characters written on the current line - - [events] is the write events in reverse order, head event is last written - *) + let updateMode (newlineWasAdded : bool) (ctx : context) = + match ctx.mode with + | Standard -> ctx + | ConfirmedMultiline -> ctx + | TrySingleLine -> + { + ctx with + mode = + (if newlineWasAdded || ctx.current_line_column > ctx.max_line_length + then ConfirmedMultiline + else TrySingleLine); + } let id x = x @@ -102,9 +121,14 @@ module CodePrinter = struct events = Write str :: ctx.events; current_line_column = ctx.current_line_column + String.length str; } + |> updateMode false (** compose two context transforming functions *) - let ( +> ) f g ctx = g (f ctx) + let ( +> ) f g ctx = + let fCtx = f ctx in + match fCtx.mode with + | ConfirmedMultiline -> fCtx + | _ -> g fCtx let sepNln ctx = { @@ -113,6 +137,8 @@ module CodePrinter = struct current_line_column = ctx.current_indent; line_count = ctx.line_count + 1; } + |> updateMode true + let sepSpace ctx = !-" " ctx let sepComma ctx = !-", " ctx let sepSemi ctx = !-"; " ctx @@ -156,13 +182,20 @@ module CodePrinter = struct let expressionFitsOnRestOfLine (f : appendEvents) (fallback : appendEvents) (ctx : context) = - (* create a short context and check if the expression fits on the current line *) - let shortCtx = f ctx in - if - ctx.line_count == shortCtx.line_count - && shortCtx.current_line_column <= ctx.max_line_length - then shortCtx - else fallback ctx + match ctx.mode with + | ConfirmedMultiline -> ctx + | _ -> ( + let shortCtx = + match ctx.mode with + | Standard -> {ctx with mode = TrySingleLine} + | _ -> ctx + in + let resultCtx = f shortCtx in + match resultCtx.mode with + | ConfirmedMultiline -> fallback ctx + | TrySingleLine -> {resultCtx with mode = ctx.mode} + | Standard -> + failwith "Unexpected Standard mode after trying SingleLine mode") let rec genOak (oak : oak) : appendEvents = match oak with @@ -240,6 +273,11 @@ module CodePrinter = struct expressionFitsOnRestOfLine short long end +(* + Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/prettier_printer.ml +*) + +(* open DSL let oak = @@ -271,10 +309,6 @@ let oak = {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; ] -(* let _ = + let _ = CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} |> CodePrinter.dump |> Format.printf "%s\n" *) - -(* - Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/prettier_printer.ml -*) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 2f4955ef8..c97850c9d 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -182,5 +182,4 @@ let print_type_expr (typ : Types.type_expr) : string = let print_full (full : SharedTypes.full) : string = CodePrinter.genOak (Transform.mk_full full) CodePrinter.emptyContext - |> CodePrinter.debug_context |> CodePrinter.dump From d7af0288501e34e4eb2e80700ddb79d62adfc765 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Oct 2024 16:42:57 +0200 Subject: [PATCH 10/24] Extend mk_package --- tools/src/print_tast.ml | 73 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 73 insertions(+) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index c97850c9d..49b306168 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -123,6 +123,55 @@ module Transform = struct } :: fields) + let mk_FileSet (fileSet : SharedTypes.FileSet.t) : oak = + List (fileSet |> SharedTypes.FileSet.to_list |> List.map (fun s -> String s)) + + let mk_builtInCompletionModules + (builtInCompletionModules : SharedTypes.builtInCompletionModules) : oak = + Record + [ + { + name = "arrayModulePath"; + value = mk_string_list builtInCompletionModules.arrayModulePath; + }; + { + name = "optionModulePath"; + value = mk_string_list builtInCompletionModules.optionModulePath; + }; + { + name = "stringModulePath"; + value = mk_string_list builtInCompletionModules.stringModulePath; + }; + { + name = "intModulePath"; + value = mk_string_list builtInCompletionModules.intModulePath; + }; + { + name = "floatModulePath"; + value = mk_string_list builtInCompletionModules.floatModulePath; + }; + { + name = "promiseModulePath"; + value = mk_string_list builtInCompletionModules.promiseModulePath; + }; + { + name = "listModulePath"; + value = mk_string_list builtInCompletionModules.listModulePath; + }; + { + name = "resultModulePath"; + value = mk_string_list builtInCompletionModules.resultModulePath; + }; + { + name = "exnModulePath"; + value = mk_string_list builtInCompletionModules.exnModulePath; + }; + { + name = "regexpModulePath"; + value = mk_string_list builtInCompletionModules.regexpModulePath; + }; + ] + let mk_package (package : SharedTypes.package) : oak = Record [ @@ -130,6 +179,30 @@ module Transform = struct name = "genericJsxModule"; value = mk_string_option package.genericJsxModule; }; + {name = "suffix"; value = String package.suffix}; + {name = "rootPath"; value = String package.rootPath}; + {name = "projectFiles"; value = mk_FileSet package.projectFiles}; + { + name = "dependenciesFiles"; + value = mk_FileSet package.dependenciesFiles; + }; + {name = "namespace"; value = mk_string_option package.namespace}; + { + name = "builtInCompletionModules"; + value = mk_builtInCompletionModules package.builtInCompletionModules; + }; + {name = "opens"; value = mk_string_list (List.concat package.opens)}; + {name = "uncurried"; value = mk_bool package.uncurried}; + { + name = "rescriptVersion"; + value = + (let major, minor = package.rescriptVersion in + Tuple + [ + {name = "major"; value = String (string_of_int major)}; + {name = "minor"; value = String (string_of_int minor)}; + ]); + }; ] let mk_Uri (uri : Uri.t) : oak = String (Uri.toString uri) From 2c487c53332d7b1b974c62eead915d1ac2339c43 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Oct 2024 16:44:45 +0200 Subject: [PATCH 11/24] Wrap tuple in parentheses in named field --- tools/src/prettier_printer.ml | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index c1a135b8a..e2e276619 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -245,13 +245,18 @@ module CodePrinter = struct and genIdent (ident : string) : appendEvents = !-ident and genNamedField (field : namedField) : appendEvents = - let short = !-(field.name) +> sepEq +> genOak field.value in + let genValue = + match field.value with + | Tuple _ -> sepOpenT +> genOak field.value +> sepCloseT + | _ -> genOak field.value + in + let short = !-(field.name) +> sepEq +> genValue in let long = !-(field.name) +> sepEq +> match field.value with | List _ | Record _ -> genOak field.value - | _ -> indentAndNln (genOak field.value) + | _ -> indentAndNln genValue in expressionFitsOnRestOfLine short long From f6fd9a7330d048cbae9e4760c579701cb2ea1a03 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Oct 2024 17:07:37 +0200 Subject: [PATCH 12/24] Complete mk_type_desc --- tools/src/prettier_printer.ml | 26 +++----- tools/src/print_tast.ml | 116 +++++++++++++++++++++++++--------- 2 files changed, 95 insertions(+), 47 deletions(-) diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index e2e276619..60639e3f8 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -1,12 +1,10 @@ (* open Analysis *) module DSL = struct - type application = {name: string; argument: oak} - - and namedField = {name: string; value: oak} + type namedField = {name: string; value: oak} and oak = - | Application of application + | Application of string * oak | Record of namedField list | Ident of string | Tuple of namedField list @@ -90,7 +88,7 @@ module CodePrinter = struct let mode = match ctx.mode with | Standard -> "Standard" - | TrySingleLine _ -> "TrySingleLine" + | TrySingleLine -> "TrySingleLine" | ConfirmedMultiline -> "ConfirmedMultiline" in Format.printf @@ -199,24 +197,20 @@ module CodePrinter = struct let rec genOak (oak : oak) : appendEvents = match oak with - | Application application -> genApplication application + | Application (name, argument) -> genApplication name argument | Record record -> genRecord record | Ident ident -> genIdent ident | String str -> !-(Format.sprintf "\"%s\"" str) | Tuple ts -> genTuple ts | List xs -> genList xs - and genApplication (application : application) : appendEvents = - let short = - !-(application.name) +> sepOpenT - +> genOak application.argument - +> sepCloseT - in + and genApplication (name : string) (argument : oak) : appendEvents = + let short = !-name +> sepOpenT +> genOak argument +> sepCloseT in let long = - !-(application.name) +> sepOpenT - +> (match application.argument with - | List _ | Record _ -> genOak application.argument - | _ -> indentAndNln (genOak application.argument) +> sepNln) + !-name +> sepOpenT + +> (match argument with + | List _ | Record _ -> genOak argument + | _ -> indentAndNln (genOak argument) +> sepNln) +> sepCloseT in expressionFitsOnRestOfLine short long diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index 49b306168..b780a5ce8 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -8,7 +8,7 @@ module Transform = struct let mk_string_option (o : string option) : oak = match o with | None -> Ident "None" - | Some s -> Application {name = "Some"; argument = String s} + | Some s -> Application ("Some", String s) let mk_string_list (items : string list) : oak = List (items |> List.map (fun s -> String s)) @@ -36,50 +36,105 @@ module Transform = struct | Reither _ -> Ident "row_field.Reither" | Rabsent -> Ident "row_field.Rabsent" + let mk_field_kind = function + | Types.Fvar _ -> Ident "field_kind.Fvar" + | Types.Fpresent -> Ident "field_kind.Fpresent" + | Types.Fabsent -> Ident "field_kind.Fabsent" + let rec mk_type_desc (desc : Types.type_desc) : oak = match desc with - | Tlink {desc} -> - Application {name = "type_desc.Tlink"; argument = mk_type_desc desc} + | Tlink {desc} -> Application ("type_desc.Tlink", mk_type_desc desc) | Tvar var -> ( match var with - | None -> Application {name = "type_desc.Tvar"; argument = Ident "None"} - | Some s -> Application {name = "type_desc.Tvar"; argument = Ident s}) + | None -> Application ("type_desc.Tvar", Ident "None") + | Some s -> Application ("type_desc.Tvar", Ident s)) | Tconstr (path, ts, _) -> let ts = ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) in Application - { - name = "type_desc.Tconstr"; - argument = - Tuple - [ - {name = "path"; value = Ident (path_to_string path)}; - {name = "ts"; value = List ts}; - ]; - } + ( "type_desc.Tconstr", + Tuple + [ + {name = "path"; value = Ident (path_to_string path)}; + {name = "ts"; value = List ts}; + ] ) | Tarrow (_, t1, t2, _) -> Application - { - name = "type_desc.Tarrow"; - argument = + ( "type_desc.Tarrow", + Tuple + [ + {name = "t1"; value = mk_type_desc t1.desc}; + {name = "t2"; value = mk_type_desc t2.desc}; + ] ) + | Ttuple ts -> + let ts = + ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) + in + Application ("type_desc.Ttuple", List ts) + | Tobject (t, r) -> ( + match !r with + | None -> Application ("type_desc.Tobject", mk_type_desc t.desc) + | Some (path, ts) -> + Application + ( "type_desc.Tobject", Tuple [ - {name = "t1"; value = mk_type_desc t1.desc}; - {name = "t2"; value = mk_type_desc t2.desc}; - ]; - } - | Ttuple _ -> Ident "type_desc.Ttuple" - | Tobject _ -> Ident "type_desc.Tobject" - | Tfield _ -> Ident "type_desc.Tfield" + {name = "type_expr"; value = mk_type_desc t.desc}; + {name = "path"; value = Ident (path_to_string path)}; + { + name = "ts"; + value = + List + (ts + |> List.map (fun (t : Types.type_expr) -> + mk_type_desc t.desc)); + }; + ] )) + | Tfield (field, fk, t1, t2) -> + Application + ( "type_desc.Tfield", + Tuple + [ + {name = "name"; value = String field}; + {name = "field_kind"; value = mk_field_kind fk}; + {name = "t1"; value = mk_type_desc t1.desc}; + {name = "t2"; value = mk_type_desc t2.desc}; + ] ) | Tnil -> Ident "type_desc.Tnil" - | Tsubst _ -> Ident "type_desc.Tsubst" + | Tsubst t -> Application ("type_desc.Tsubst", mk_type_desc t.desc) | Tvariant row_descr -> + Application ("type_desc.Tvariant", mk_row_desc row_descr) + | Tunivar so -> Application ("type_desc.Tunivar", mk_string_option so) + | Tpoly (t, ts) -> + let ts = + ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) + in + Application + ( "type_desc.Tpoly", + Tuple + [ + {name = "t"; value = mk_type_desc t.desc}; + {name = "ts"; value = List ts}; + ] ) + | Tpackage (path, lids, ts) -> + let lids = + lids + |> List.map (fun (lid : Longident.t) -> + List + (Longident.flatten lid |> List.map (fun ident -> String ident))) + in + let ts = + ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) + in Application - {name = "type_desc.Tvariant"; argument = mk_row_desc row_descr} - | Tunivar _ -> Ident "type_desc.Tunivar" - | Tpoly _ -> Ident "type_desc.Tpoly" - | Tpackage _ -> Ident "type_desc.Tpackage" + ( "type_desc.Tpackage", + Tuple + [ + {name = "path"; value = Ident (path_to_string path)}; + {name = "lids"; value = List lids}; + {name = "ts"; value = List ts}; + ] ) and mk_row_desc (row_desc : Types.row_desc) : oak = let fields = @@ -211,8 +266,7 @@ module Transform = struct let kind = match item.kind with | SharedTypes.Module.Value v -> - Application - {name = "SharedTypes.Module.Value"; argument = mk_type_desc v.desc} + Application ("SharedTypes.Module.Value", mk_type_desc v.desc) | SharedTypes.Module.Type _ -> Ident "Type" | SharedTypes.Module.Module _ -> Ident "Module" in From e1227bcf2b84fcf921655c4362878def88e823f6 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Oct 2024 09:34:54 +0200 Subject: [PATCH 13/24] Add support for Type.t --- tools/src/print_tast.ml | 215 +++++++++++++++++++++++++++++++++++----- 1 file changed, 190 insertions(+), 25 deletions(-) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index b780a5ce8..f42dccfc3 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -5,13 +5,21 @@ open Analysis module Transform = struct let mk_bool (b : bool) : oak = if b then Ident "true" else Ident "false" - let mk_string_option (o : string option) : oak = + let mk_option f o = match o with | None -> Ident "None" - | Some s -> Application ("Some", String s) + | Some x -> Application ("Some", f x) + + let mk_string_option (o : string option) : oak = + mk_option (fun s -> String s) o + + let mk_list f l = List (List.map f l) let mk_string_list (items : string list) : oak = - List (items |> List.map (fun s -> String s)) + mk_list (fun s -> String s) items + + let mk_int_list (items : int list) : oak = + mk_list (fun i -> Ident (string_of_int i)) items let path_to_string path = let buf = Buffer.create 64 in @@ -44,20 +52,14 @@ module Transform = struct let rec mk_type_desc (desc : Types.type_desc) : oak = match desc with | Tlink {desc} -> Application ("type_desc.Tlink", mk_type_desc desc) - | Tvar var -> ( - match var with - | None -> Application ("type_desc.Tvar", Ident "None") - | Some s -> Application ("type_desc.Tvar", Ident s)) + | Tvar var -> Application ("type_desc.Tvar", mk_string_option var) | Tconstr (path, ts, _) -> - let ts = - ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) - in Application ( "type_desc.Tconstr", Tuple [ {name = "path"; value = Ident (path_to_string path)}; - {name = "ts"; value = List ts}; + {name = "ts"; value = mk_type_expr_list ts}; ] ) | Tarrow (_, t1, t2, _) -> Application @@ -67,11 +69,7 @@ module Transform = struct {name = "t1"; value = mk_type_desc t1.desc}; {name = "t2"; value = mk_type_desc t2.desc}; ] ) - | Ttuple ts -> - let ts = - ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) - in - Application ("type_desc.Ttuple", List ts) + | Ttuple ts -> Application ("type_desc.Ttuple", mk_type_expr_list ts) | Tobject (t, r) -> ( match !r with | None -> Application ("type_desc.Tobject", mk_type_desc t.desc) @@ -107,15 +105,12 @@ module Transform = struct Application ("type_desc.Tvariant", mk_row_desc row_descr) | Tunivar so -> Application ("type_desc.Tunivar", mk_string_option so) | Tpoly (t, ts) -> - let ts = - ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) - in Application ( "type_desc.Tpoly", Tuple [ {name = "t"; value = mk_type_desc t.desc}; - {name = "ts"; value = List ts}; + {name = "ts"; value = mk_type_expr_list ts}; ] ) | Tpackage (path, lids, ts) -> let lids = @@ -124,16 +119,13 @@ module Transform = struct List (Longident.flatten lid |> List.map (fun ident -> String ident))) in - let ts = - ts |> List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) - in Application ( "type_desc.Tpackage", Tuple [ {name = "path"; value = Ident (path_to_string path)}; {name = "lids"; value = List lids}; - {name = "ts"; value = List ts}; + {name = "ts"; value = mk_type_expr_list ts}; ] ) and mk_row_desc (row_desc : Types.row_desc) : oak = @@ -178,6 +170,9 @@ module Transform = struct } :: fields) + and mk_type_expr_list ts = + List (List.map (fun (t : Types.type_expr) -> mk_type_desc t.desc) ts) + let mk_FileSet (fileSet : SharedTypes.FileSet.t) : oak = List (fileSet |> SharedTypes.FileSet.to_list |> List.map (fun s -> String s)) @@ -262,12 +257,182 @@ module Transform = struct let mk_Uri (uri : Uri.t) : oak = String (Uri.toString uri) + let mk_rec_status = function + | Types.Trec_not -> Ident "Trec_not" + | Types.Trec_first -> Ident "Trec_first" + | Types.Trec_next -> Ident "Trec_next" + + let mk_field (field : SharedTypes.field) : oak = + Record + [ + {name = "stamp"; value = Ident (string_of_int field.stamp)}; + {name = "fname"; value = String field.fname.txt}; + {name = "typ"; value = mk_type_desc field.typ.desc}; + {name = "optional"; value = mk_bool field.optional}; + {name = "docstring"; value = mk_string_list field.docstring}; + {name = "deprecated"; value = mk_string_option field.deprecated}; + ] + + let mk_pos (pos : Lexing.position) : oak = + Record + [ + {name = "pos_fname"; value = String pos.pos_fname}; + {name = "pos_lnum"; value = Ident (string_of_int pos.pos_lnum)}; + {name = "pos_bol"; value = Ident (string_of_int pos.pos_bol)}; + {name = "pos_cnum"; value = Ident (string_of_int pos.pos_cnum)}; + ] + + let mk_location (loc : Location.t) = + Record + [ + {name = "loc_start"; value = mk_pos loc.loc_start}; + {name = "loc_end"; value = mk_pos loc.loc_end}; + {name = "loc_ghost"; value = mk_bool loc.loc_ghost}; + ] + + let mk_string_loc (loc : string Location.loc) : oak = + Record + [ + {name = "txt"; value = String loc.txt}; + {name = "loc"; value = mk_location loc.loc}; + ] + + let mk_constructor_args (args : SharedTypes.constructorArgs) : oak = + match args with + | SharedTypes.InlineRecord fields -> + Application + ("constructorArgs.InlineRecord", List (fields |> List.map mk_field)) + | SharedTypes.Args ts -> + let ts = + ts + |> List.map (fun ((t : Types.type_expr), loc) -> + Tuple + [ + {name = "type"; value = mk_type_desc t.desc}; + {name = "loc"; value = mk_location loc}; + ]) + in + Application ("constructorArgs.Tuple", List ts) + + let mk_constructor (ctor : SharedTypes.Constructor.t) : oak = + Record + [ + {name = "stamp"; value = Ident (string_of_int ctor.stamp)}; + { + name = "cname"; + value = + Record + [ + {name = "txt"; value = String ctor.cname.txt}; + {name = "loc"; value = mk_location ctor.cname.loc}; + ]; + }; + {name = "args"; value = mk_constructor_args ctor.args}; + {name = "docstring"; value = mk_string_list ctor.docstring}; + {name = "deprecated"; value = mk_string_option ctor.deprecated}; + ] + let mk_attribute_payload (payload : Parsetree.payload) : oak = + match payload with + | PStr _ -> Ident "payload.PStr" + | PSig _ -> Ident "payload.PSig" + | PTyp _ -> Ident "payload.PTyp" + | PPat _ -> Ident "payload.PPat" + + let mk_attribute (attribute : Parsetree.attribute) : oak = + let loc, payload = attribute in + Tuple + [ + {name = "loc"; value = mk_string_loc loc}; + {name = "payload"; value = mk_attribute_payload payload}; + ] + + let mk_attribute_list (attributes : Parsetree.attributes) = + List (attributes |> List.map mk_attribute) + + let mk_type_kind (kind : SharedTypes.Type.kind) : oak = + match kind with + | SharedTypes.Type.Abstract _ -> Ident "Type.kind.Abstract" + | SharedTypes.Type.Open -> Ident "Type.kind.Open" + | SharedTypes.Type.Tuple ts -> + Application ("Type.kind.Tuple", mk_type_expr_list ts) + | SharedTypes.Type.Record fields -> + let fields = List.map mk_field fields in + Application ("Type.kind.Record", List fields) + | SharedTypes.Type.Variant ctors -> + Application ("Type.kind.Variant", List (ctors |> List.map mk_constructor)) + + let mk_type_declaration_type_kind (type_kind : Types.type_kind) : oak = + match type_kind with + | Type_abstract -> Ident "type_kind.Type_abstract" + | Type_variant _ -> Ident "type_kind.Type_variant" + | Type_record _ -> Ident "type_kind.Type_record" + | Type_open -> Ident "type_kind.Type_open" + + let mk_private_flag = function + | Asttypes.Private -> Ident "Private" + | Asttypes.Public -> Ident "Public" + + let mk_unboxed_status (status : Types.unboxed_status) : oak = + Record + [ + {name = "unboxed"; value = mk_bool status.unboxed}; + {name = "default"; value = mk_bool status.default}; + ] + + let mk_type_declaration (td : Types.type_declaration) : oak = + Record + [ + {name = "type_params"; value = mk_type_expr_list td.type_params}; + {name = "type_arity"; value = Ident (string_of_int td.type_arity)}; + {name = "type_kind"; value = mk_type_declaration_type_kind td.type_kind}; + {name = "type_private"; value = mk_private_flag td.type_private}; + { + name = "type_manifest"; + value = + mk_option + (fun (te : Types.type_expr) -> mk_type_desc te.desc) + td.type_manifest; + }; + { + name = "type_newtype_level"; + value = + mk_option + (fun (i1, i2) -> + Tuple + [ + {name = "i1"; value = Ident (string_of_int i1)}; + {name = "i2"; value = Ident (string_of_int i2)}; + ]) + td.type_newtype_level; + }; + {name = "type_loc"; value = mk_location td.type_loc}; + {name = "type_attributes"; value = mk_attribute_list td.type_attributes}; + {name = "type_immediate"; value = mk_bool td.type_immediate}; + {name = "type_unboxed"; value = mk_unboxed_status td.type_unboxed}; + ] + + let mk_type (type_ : SharedTypes.Type.t) : oak = + Record + [ + {name = "kind"; value = mk_type_kind type_.kind}; + {name = "decl"; value = mk_type_declaration type_.decl}; + {name = "name"; value = String type_.name}; + {name = "attributes"; value = mk_attribute_list type_.attributes}; + ] + let mk_item (item : SharedTypes.Module.item) : oak = let kind = match item.kind with | SharedTypes.Module.Value v -> Application ("SharedTypes.Module.Value", mk_type_desc v.desc) - | SharedTypes.Module.Type _ -> Ident "Type" + | SharedTypes.Module.Type (t, rec_status) -> + Application + ( "Type", + Tuple + [ + {name = "type"; value = mk_type t}; + {name = "rec_status"; value = mk_rec_status rec_status}; + ] ) | SharedTypes.Module.Module _ -> Ident "Module" in Record From 2c2e5b7e98d2c8e0a39085fbdb3da5b21f029625 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Oct 2024 09:43:08 +0200 Subject: [PATCH 14/24] Print module --- tools/src/print_tast.ml | 52 +++++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 15 deletions(-) diff --git a/tools/src/print_tast.ml b/tools/src/print_tast.ml index f42dccfc3..4f8b1e997 100644 --- a/tools/src/print_tast.ml +++ b/tools/src/print_tast.ml @@ -38,6 +38,8 @@ module Transform = struct aux path; Buffer.contents buf + let mk_path path = Ident (path_to_string path) + let mk_row_field (row_field : Types.row_field) : oak = match row_field with | Rpresent _ -> Ident "row_field.Rpresent" @@ -58,7 +60,7 @@ module Transform = struct ( "type_desc.Tconstr", Tuple [ - {name = "path"; value = Ident (path_to_string path)}; + {name = "path"; value = mk_path path}; {name = "ts"; value = mk_type_expr_list ts}; ] ) | Tarrow (_, t1, t2, _) -> @@ -79,7 +81,7 @@ module Transform = struct Tuple [ {name = "type_expr"; value = mk_type_desc t.desc}; - {name = "path"; value = Ident (path_to_string path)}; + {name = "path"; value = mk_path path}; { name = "ts"; value = @@ -123,7 +125,7 @@ module Transform = struct ( "type_desc.Tpackage", Tuple [ - {name = "path"; value = Ident (path_to_string path)}; + {name = "path"; value = mk_path path}; {name = "lids"; value = List lids}; {name = "ts"; value = mk_type_expr_list ts}; ] ) @@ -157,7 +159,7 @@ module Transform = struct value = Tuple [ - {name = "Path.t"; value = Ident (path_to_string path)}; + {name = "Path.t"; value = mk_path path}; { name = "fields"; value = @@ -419,8 +421,30 @@ module Transform = struct {name = "name"; value = String type_.name}; {name = "attributes"; value = mk_attribute_list type_.attributes}; ] + let rec mk_structure (structure : SharedTypes.Module.structure) : oak = + Record + [ + {name = "name"; value = String structure.name}; + {name = "docstring"; value = mk_string_list structure.docstring}; + {name = "items"; value = List (List.map mk_item structure.items)}; + {name = "deprecated"; value = mk_string_option structure.deprecated}; + ] + + and mk_module (module_ : SharedTypes.Module.t) : oak = + match module_ with + | SharedTypes.Module.Ident path -> Application ("Ident", mk_path path) + | SharedTypes.Module.Structure structure -> + Application ("Structure", mk_structure structure) + | SharedTypes.Module.Constraint (t1, t2) -> + Application + ( "Constraint", + Tuple + [ + {name = "t1"; value = mk_module t1}; + {name = "t2"; value = mk_module t2}; + ] ) - let mk_item (item : SharedTypes.Module.item) : oak = + and mk_item (item : SharedTypes.Module.item) : oak = let kind = match item.kind with | SharedTypes.Module.Value v -> @@ -433,7 +457,14 @@ module Transform = struct {name = "type"; value = mk_type t}; {name = "rec_status"; value = mk_rec_status rec_status}; ] ) - | SharedTypes.Module.Module _ -> Ident "Module" + | SharedTypes.Module.Module m -> + Application + ( "Module", + Record + [ + {name = "type_"; value = mk_module m.type_}; + {name = "isModuleType"; value = mk_bool m.isModuleType}; + ] ) in Record [ @@ -443,15 +474,6 @@ module Transform = struct {name = "deprecated"; value = mk_string_option item.deprecated}; ] - let mk_structure (structure : SharedTypes.Module.structure) : oak = - Record - [ - {name = "name"; value = String structure.name}; - {name = "docstring"; value = mk_string_list structure.docstring}; - {name = "items"; value = List (List.map mk_item structure.items)}; - {name = "deprecated"; value = mk_string_option structure.deprecated}; - ] - let mk_file (file : SharedTypes.File.t) : oak = Record [ From eff807fdf697ce998323f5c86a84362e7983b15e Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Oct 2024 09:47:47 +0200 Subject: [PATCH 15/24] Simplify dump code --- tools/src/tools.ml | 37 +++++++++++-------------------------- 1 file changed, 11 insertions(+), 26 deletions(-) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index a784a6863..2c3ee7a35 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -641,42 +641,27 @@ let extractEmbedded ~extensionPoints ~filename = ]) |> List.rev |> array +(** Dump the contents of a typed tree file *) let dump entryPointFile = let path = - match Filename.is_relative entryPointFile with - | true -> Unix.realpath entryPointFile - | false -> entryPointFile + if Filename.is_relative entryPointFile then Unix.realpath entryPointFile + else entryPointFile in let result = - match + if FindFiles.isImplementation path = false && FindFiles.isInterface path = false - with - | false -> ( - let path = - if FindFiles.isImplementation path then - let pathAsResi = - (path |> Filename.dirname) ^ "/" - ^ (path |> Filename.basename |> Filename.chop_extension) - ^ ".resi" - in - if Sys.file_exists pathAsResi then ( - Printf.printf "preferring found resi file for impl: %s\n" pathAsResi; - pathAsResi) - else path - else path - in + then + Error + (Printf.sprintf + "error: failed to read %s, expected an .res or .resi file" path) + else match Cmt.loadFullCmtFromPath ~path with | None -> Error (Printf.sprintf - "error: failed to generate doc for %s, try to build the project" - path) - | Some full -> Ok (Print_tast.print_full full)) - | true -> - Error - (Printf.sprintf - "error: failed to read %s, expected an .res or .resi file" path) + "error: failed to dump for %s, try to build the project" path) + | Some full -> Ok (Print_tast.print_full full) in result From 3adb001a0134b3d7ec2c76ee9dab2d5df3a335b9 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Oct 2024 13:59:07 +0200 Subject: [PATCH 16/24] Clean up printer file --- tools/src/prettier_printer.ml | 42 ----------------------------------- tools/src/printer_sandbox.ml | 39 ++++++++++++++++++++++++++++++++ 2 files changed, 39 insertions(+), 42 deletions(-) create mode 100644 tools/src/printer_sandbox.ml diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index 60639e3f8..f719f6409 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -1,5 +1,3 @@ -(* open Analysis *) - module DSL = struct type namedField = {name: string; value: oak} @@ -271,43 +269,3 @@ module CodePrinter = struct in expressionFitsOnRestOfLine short long end - -(* - Interpret using ocaml /home/nojaf/projects/rescript-vscode/tools/src/prettier_printer.ml -*) - -(* -open DSL - -let oak = - DSL.Record - [ - { - name = "zig"; - value = - DSL.Record - [ - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - {name = "member"; value = Ident "Zigbaaaaaaaaar"}; - ]; - }; - { - name = "roxas"; - value = - List - [ - Ident "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"; - Ident "meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"; - DSL.Record - [ - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - {name = "member"; value = Ident "Zigbaaaaaaaaar"}; - ]; - ]; - }; - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - ] - - let _ = - CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} - |> CodePrinter.dump |> Format.printf "%s\n" *) diff --git a/tools/src/printer_sandbox.ml b/tools/src/printer_sandbox.ml new file mode 100644 index 000000000..31764e7f7 --- /dev/null +++ b/tools/src/printer_sandbox.ml @@ -0,0 +1,39 @@ +#use "prettier_printer.ml";; +(* + Interpret using ocaml ./tools/src/printer_sandbox.ml +*) + +open DSL + +let oak = + Record + [ + { + name = "hello"; + value = + Record + [ + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + {name = "member"; value = Ident "baazaaaaaaar"}; + ]; + }; + { + name = "roxas"; + value = + List + [ + Ident "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"; + Ident "meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"; + Record + [ + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + {name = "member"; value = Ident "bazaaaaaaaaar"}; + ]; + ]; + }; + {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; + ] + +let _ = + CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} + |> CodePrinter.dump |> Format.printf "%s\n" From 47c4f797fddfa43292df67f5383e44dfcb86a7bc Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Oct 2024 16:52:24 +0200 Subject: [PATCH 17/24] Update expected files --- tools/src/printer_sandbox.ml | 6 +- tools/src/tools.ml | 1 - .../src/expected/DocExtraction2.res.json | 16 +++++ .../src/expected/DocExtraction2.resi.json | 16 +++++ .../src/expected/DocExtractionRes.res.json | 68 +++++++++++++++++++ tools/tests/src/expected/ModC.res.json | 5 ++ tools/tests/src/expected/ModC.resi.json | 5 ++ 7 files changed, 114 insertions(+), 3 deletions(-) diff --git a/tools/src/printer_sandbox.ml b/tools/src/printer_sandbox.ml index 31764e7f7..7fd1b035f 100644 --- a/tools/src/printer_sandbox.ml +++ b/tools/src/printer_sandbox.ml @@ -1,7 +1,8 @@ -#use "prettier_printer.ml";; (* +#use "prettier_printer.ml";; + Interpret using ocaml ./tools/src/printer_sandbox.ml -*) + open DSL @@ -37,3 +38,4 @@ let oak = let _ = CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} |> CodePrinter.dump |> Format.printf "%s\n" +*) \ No newline at end of file diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 2c3ee7a35..fffac4fef 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -360,7 +360,6 @@ let isFunction = function | _ -> false let valueDetail (typ : Types.type_expr) = - Printf.printf "%s\n" (Print_tast.print_type_expr typ); let rec collectSignatureTypes (typ_desc : Types.type_desc) = match typ_desc with | Tlink t -> collectSignatureTypes t.desc diff --git a/tools/tests/src/expected/DocExtraction2.res.json b/tools/tests/src/expected/DocExtraction2.res.json index 224daefdc..770dbe1a6 100644 --- a/tools/tests/src/expected/DocExtraction2.res.json +++ b/tools/tests/src/expected/DocExtraction2.res.json @@ -30,6 +30,14 @@ "filepath": "src/DocExtraction2.resi", "line": 7, "col": 1 + }, + "detail": { + "parameters": [{ + "path": "unit" + }], + "returnType": { + "path": "t" + } } }, { @@ -65,6 +73,14 @@ "filepath": "src/DocExtraction2.resi", "line": 15, "col": 3 + }, + "detail": { + "parameters": [{ + "path": "unit" + }], + "returnType": { + "path": "t" + } } }] }] diff --git a/tools/tests/src/expected/DocExtraction2.resi.json b/tools/tests/src/expected/DocExtraction2.resi.json index 224daefdc..770dbe1a6 100644 --- a/tools/tests/src/expected/DocExtraction2.resi.json +++ b/tools/tests/src/expected/DocExtraction2.resi.json @@ -30,6 +30,14 @@ "filepath": "src/DocExtraction2.resi", "line": 7, "col": 1 + }, + "detail": { + "parameters": [{ + "path": "unit" + }], + "returnType": { + "path": "t" + } } }, { @@ -65,6 +73,14 @@ "filepath": "src/DocExtraction2.resi", "line": 15, "col": 3 + }, + "detail": { + "parameters": [{ + "path": "unit" + }], + "returnType": { + "path": "t" + } } }] }] diff --git a/tools/tests/src/expected/DocExtractionRes.res.json b/tools/tests/src/expected/DocExtractionRes.res.json index 93a727b3b..4c6dd2b1f 100644 --- a/tools/tests/src/expected/DocExtractionRes.res.json +++ b/tools/tests/src/expected/DocExtractionRes.res.json @@ -45,6 +45,14 @@ "filepath": "src/DocExtractionRes.res", "line": 17, "col": 5 + }, + "detail": { + "parameters": [{ + "path": "string" + }], + "returnType": { + "path": "t" + } } }, { @@ -57,6 +65,14 @@ "filepath": "src/DocExtractionRes.res", "line": 23, "col": 5 + }, + "detail": { + "parameters": [{ + "path": "t" + }], + "returnType": { + "path": "t" + } } }, { @@ -69,6 +85,11 @@ "filepath": "src/DocExtractionRes.res", "line": 26, "col": 5 + }, + "detail": { + "returnType": { + "path": "int" + } } }, { @@ -184,6 +205,14 @@ "filepath": "src/DocExtractionRes.res", "line": 49, "col": 7 + }, + "detail": { + "parameters": [{ + "path": "SomeInnerModule.status" + }], + "returnType": { + "path": "bool" + } } }, { @@ -268,6 +297,14 @@ "filepath": "src/DocExtractionRes.res", "line": 71, "col": 3 + }, + "detail": { + "parameters": [{ + "path": "unit" + }], + "returnType": { + "path": "t" + } } }] }, @@ -304,6 +341,14 @@ "filepath": "src/DocExtractionRes.res", "line": 109, "col": 3 + }, + "detail": { + "parameters": [{ + "path": "t" + }], + "returnType": { + "path": "t" + } } }] }, @@ -341,6 +386,14 @@ "filepath": "src/DocExtractionRes.res", "line": 128, "col": 7 + }, + "detail": { + "parameters": [{ + "path": "int" + }], + "returnType": { + "path": "int" + } } }] }, @@ -365,6 +418,11 @@ "filepath": "src/DocExtractionRes.res", "line": 132, "col": 3 + }, + "detail": { + "returnType": { + "path": "int" + } } }] }, @@ -390,6 +448,11 @@ "filepath": "src/DocExtractionRes.res", "line": 136, "col": 7 + }, + "detail": { + "returnType": { + "path": "int" + } } }] }, @@ -426,6 +489,11 @@ "filepath": "src/DocExtractionRes.res", "line": 141, "col": 9 + }, + "detail": { + "returnType": { + "path": "int" + } } }] }] diff --git a/tools/tests/src/expected/ModC.res.json b/tools/tests/src/expected/ModC.res.json index 4f68f6191..cff8a7315 100644 --- a/tools/tests/src/expected/ModC.res.json +++ b/tools/tests/src/expected/ModC.res.json @@ -29,6 +29,11 @@ "filepath": "src/ModC.resi", "line": 5, "col": 3 + }, + "detail": { + "returnType": { + "path": "string" + } } }] }] diff --git a/tools/tests/src/expected/ModC.resi.json b/tools/tests/src/expected/ModC.resi.json index 4f68f6191..cff8a7315 100644 --- a/tools/tests/src/expected/ModC.resi.json +++ b/tools/tests/src/expected/ModC.resi.json @@ -29,6 +29,11 @@ "filepath": "src/ModC.resi", "line": 5, "col": 3 + }, + "detail": { + "returnType": { + "path": "string" + } } }] }] From 1e14581ceac77957152db54d2d8480082e93258f Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 12 Oct 2024 11:51:48 +0200 Subject: [PATCH 18/24] Update ReScript bindings --- tools/npm/Tools_Docgen.res | 13 +++++++++++++ tools/npm/Tools_Docgen.resi | 14 ++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/tools/npm/Tools_Docgen.res b/tools/npm/Tools_Docgen.res index c6b7d450c..197a5ee05 100644 --- a/tools/npm/Tools_Docgen.res +++ b/tools/npm/Tools_Docgen.res @@ -17,10 +17,21 @@ type constructor = { payload?: constructorPayload, } +type rec typeInSignature = { + path: string, + genericTypeParameters: array, +} + +type signatureDetais = { + parameters: array, + returnType: typeInSignature, +} + @tag("kind") type detail = | @as("record") Record({items: array}) | @as("variant") Variant({items: array}) + | @as("alias") Signature(signatureDetais) type source = { filepath: string, @@ -38,6 +49,8 @@ type rec item = name: string, deprecated?: string, source: source, + /** Additional documentation of signature, if available. */ + detail?: detail, }) | @as("type") Type({ diff --git a/tools/npm/Tools_Docgen.resi b/tools/npm/Tools_Docgen.resi index 271f65f99..e0964da76 100644 --- a/tools/npm/Tools_Docgen.resi +++ b/tools/npm/Tools_Docgen.resi @@ -16,10 +16,22 @@ type constructor = { deprecated?: string, payload?: constructorPayload, } + +type rec typeInSignature = { + path: string, + genericTypeParameters: array, +} + +type signatureDetais = { + parameters: array, + returnType: typeInSignature, +} + @tag("kind") type detail = | @as("record") Record({items: array}) | @as("variant") Variant({items: array}) + | @as("alias") Signature(signatureDetais) type source = { filepath: string, @@ -37,6 +49,8 @@ type rec item = name: string, deprecated?: string, source: source, + /** Additional documentation of signature, if available. */ + detail?: detail, }) | @as("type") Type({ From 3018283c117817ad9e6960c97cbac617969ce111 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 16 Oct 2024 12:06:42 +0200 Subject: [PATCH 19/24] Correct signature detail in JSON --- tools/npm/Tools_Docgen.resi | 2 +- tools/src/tools.ml | 12 +++- .../src/expected/DocExtraction2.res.json | 12 +++- .../src/expected/DocExtraction2.resi.json | 12 +++- .../src/expected/DocExtractionRes.res.json | 60 +++++++++++++++---- tools/tests/src/expected/ModC.res.json | 6 +- tools/tests/src/expected/ModC.resi.json | 6 +- 7 files changed, 90 insertions(+), 20 deletions(-) diff --git a/tools/npm/Tools_Docgen.resi b/tools/npm/Tools_Docgen.resi index e0964da76..3328ba671 100644 --- a/tools/npm/Tools_Docgen.resi +++ b/tools/npm/Tools_Docgen.resi @@ -31,7 +31,7 @@ type signatureDetais = { type detail = | @as("record") Record({items: array}) | @as("variant") Variant({items: array}) - | @as("alias") Signature(signatureDetais) + | @as("signature") Signature(signatureDetais) type source = { filepath: string, diff --git a/tools/src/tools.ml b/tools/src/tools.ml index fffac4fef..a2134602f 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -173,10 +173,16 @@ let stringifyDetail ?(indentation = 0) (detail : docItemDetail) = ps |> List.map (stringifyTypeDoc ~indentation:(indentation + 1)) |> fun ps -> Some (array ps) in - stringifyObject ~startOnNewline:false ~indentation + stringifyObject ~startOnNewline:true ~indentation [ - ("parameters", ps); - ("returnType", Some (stringifyTypeDoc ~indentation returnType)); + ("kind", Some (wrapInQuotes "signature")); + ( "items", + Some + (stringifyObject ~startOnNewline:false ~indentation + [ + ("parameters", ps); + ("returnType", Some (stringifyTypeDoc ~indentation returnType)); + ]) ); ] let stringifySource ~indentation source = diff --git a/tools/tests/src/expected/DocExtraction2.res.json b/tools/tests/src/expected/DocExtraction2.res.json index 770dbe1a6..fd0e7784e 100644 --- a/tools/tests/src/expected/DocExtraction2.res.json +++ b/tools/tests/src/expected/DocExtraction2.res.json @@ -31,7 +31,10 @@ "line": 7, "col": 1 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "unit" }], @@ -39,6 +42,7 @@ "path": "t" } } + } }, { "id": "DocExtraction2.InnerModule", @@ -74,7 +78,10 @@ "line": 15, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "unit" }], @@ -82,6 +89,7 @@ "path": "t" } } + } }] }] } diff --git a/tools/tests/src/expected/DocExtraction2.resi.json b/tools/tests/src/expected/DocExtraction2.resi.json index 770dbe1a6..fd0e7784e 100644 --- a/tools/tests/src/expected/DocExtraction2.resi.json +++ b/tools/tests/src/expected/DocExtraction2.resi.json @@ -31,7 +31,10 @@ "line": 7, "col": 1 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "unit" }], @@ -39,6 +42,7 @@ "path": "t" } } + } }, { "id": "DocExtraction2.InnerModule", @@ -74,7 +78,10 @@ "line": 15, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "unit" }], @@ -82,6 +89,7 @@ "path": "t" } } + } }] }] } diff --git a/tools/tests/src/expected/DocExtractionRes.res.json b/tools/tests/src/expected/DocExtractionRes.res.json index 4c6dd2b1f..bf7fa2034 100644 --- a/tools/tests/src/expected/DocExtractionRes.res.json +++ b/tools/tests/src/expected/DocExtractionRes.res.json @@ -46,7 +46,10 @@ "line": 17, "col": 5 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "string" }], @@ -54,6 +57,7 @@ "path": "t" } } + } }, { "id": "DocExtractionRes.asOffline", @@ -66,7 +70,10 @@ "line": 23, "col": 5 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "t" }], @@ -74,6 +81,7 @@ "path": "t" } } + } }, { "id": "DocExtractionRes.SomeConstant", @@ -86,11 +94,15 @@ "line": 26, "col": 5 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "int" } } + } }, { "id": "DocExtractionRes.SomeInnerModule", @@ -206,7 +218,10 @@ "line": 49, "col": 7 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "SomeInnerModule.status" }], @@ -214,6 +229,7 @@ "path": "bool" } } + } }, { "id": "DocExtractionRes.AnotherModule.someVariantWithInlineRecords", @@ -298,7 +314,10 @@ "line": 71, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "unit" }], @@ -306,6 +325,7 @@ "path": "t" } } + } }] }, { @@ -342,7 +362,10 @@ "line": 109, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "t" }], @@ -350,6 +373,7 @@ "path": "t" } } + } }] }, { @@ -387,7 +411,10 @@ "line": 128, "col": 7 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "parameters": [{ "path": "int" }], @@ -395,6 +422,7 @@ "path": "int" } } + } }] }, { @@ -419,11 +447,15 @@ "line": 132, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "int" } } + } }] }, { @@ -449,11 +481,15 @@ "line": 136, "col": 7 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "int" } } + } }] }, { @@ -490,11 +526,15 @@ "line": 141, "col": 9 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "int" } } + } }] }] }] diff --git a/tools/tests/src/expected/ModC.res.json b/tools/tests/src/expected/ModC.res.json index cff8a7315..031d09bf8 100644 --- a/tools/tests/src/expected/ModC.res.json +++ b/tools/tests/src/expected/ModC.res.json @@ -30,11 +30,15 @@ "line": 5, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "string" } } + } }] }] } diff --git a/tools/tests/src/expected/ModC.resi.json b/tools/tests/src/expected/ModC.resi.json index cff8a7315..031d09bf8 100644 --- a/tools/tests/src/expected/ModC.resi.json +++ b/tools/tests/src/expected/ModC.resi.json @@ -30,11 +30,15 @@ "line": 5, "col": 3 }, - "detail": { + "detail": + { + "kind": "signature", + "items": { "returnType": { "path": "string" } } + } }] }] } From 900278e7cf6af53c71f83c65757c392a07d34eba Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 16 Oct 2024 12:08:28 +0200 Subject: [PATCH 20/24] Refactor infix operator --- tools/src/prettier_printer.ml | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index f719f6409..118024c54 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -111,7 +111,7 @@ module CodePrinter = struct let id x = x (** add a write event to the context *) - let ( !- ) str ctx = + let write str ctx = { ctx with events = Write str :: ctx.events; @@ -135,16 +135,16 @@ module CodePrinter = struct } |> updateMode true - let sepSpace ctx = !-" " ctx - let sepComma ctx = !-", " ctx - let sepSemi ctx = !-"; " ctx - let sepOpenT ctx = !-"(" ctx - let sepCloseT ctx = !-")" ctx - let sepOpenR ctx = !-"{" ctx - let sepCloseR ctx = !-"}" ctx - let sepOpenL ctx = !-"[" ctx - let sepCloseL ctx = !-"]" ctx - let sepEq ctx = !-" = " ctx + let sepSpace ctx = write " " ctx + let sepComma ctx = write ", " ctx + let sepSemi ctx = write "; " ctx + let sepOpenT ctx = write "(" ctx + let sepCloseT ctx = write ")" ctx + let sepOpenR ctx = write "{" ctx + let sepCloseR ctx = write "}" ctx + let sepOpenL ctx = write "[" ctx + let sepCloseL ctx = write "]" ctx + let sepEq ctx = write " = " ctx let wrapInParentheses f = sepOpenT +> f +> sepCloseT let indent ctx = let nextIdent = ctx.current_indent + ctx.indent_size in @@ -198,14 +198,14 @@ module CodePrinter = struct | Application (name, argument) -> genApplication name argument | Record record -> genRecord record | Ident ident -> genIdent ident - | String str -> !-(Format.sprintf "\"%s\"" str) + | String str -> write (Format.sprintf "\"%s\"" str) | Tuple ts -> genTuple ts | List xs -> genList xs and genApplication (name : string) (argument : oak) : appendEvents = - let short = !-name +> sepOpenT +> genOak argument +> sepCloseT in + let short = write name +> sepOpenT +> genOak argument +> sepCloseT in let long = - !-name +> sepOpenT + write name +> sepOpenT +> (match argument with | List _ | Record _ -> genOak argument | _ -> indentAndNln (genOak argument) +> sepNln) @@ -234,7 +234,7 @@ module CodePrinter = struct let long = col genNamedField sepNln oaks in expressionFitsOnRestOfLine short long - and genIdent (ident : string) : appendEvents = !-ident + and genIdent (ident : string) : appendEvents = write ident and genNamedField (field : namedField) : appendEvents = let genValue = @@ -242,9 +242,9 @@ module CodePrinter = struct | Tuple _ -> sepOpenT +> genOak field.value +> sepCloseT | _ -> genOak field.value in - let short = !-(field.name) +> sepEq +> genValue in + let short = write (field.name) +> sepEq +> genValue in let long = - !-(field.name) +> sepEq + write (field.name) +> sepEq +> match field.value with | List _ | Record _ -> genOak field.value From abc13c9f94ddbfed609a9c874286de7eba991f79 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 16 Oct 2024 12:12:25 +0200 Subject: [PATCH 21/24] Remove printer_sandbox --- tools/src/printer_sandbox.ml | 41 ------------------------------------ 1 file changed, 41 deletions(-) delete mode 100644 tools/src/printer_sandbox.ml diff --git a/tools/src/printer_sandbox.ml b/tools/src/printer_sandbox.ml deleted file mode 100644 index 7fd1b035f..000000000 --- a/tools/src/printer_sandbox.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* -#use "prettier_printer.ml";; - - Interpret using ocaml ./tools/src/printer_sandbox.ml - - -open DSL - -let oak = - Record - [ - { - name = "hello"; - value = - Record - [ - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - {name = "member"; value = Ident "baazaaaaaaar"}; - ]; - }; - { - name = "roxas"; - value = - List - [ - Ident "jjjjjjjjjjjjjjjjjjjjjjjjjjjjjjj"; - Ident "meeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"; - Record - [ - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - {name = "member"; value = Ident "bazaaaaaaaaar"}; - ]; - ]; - }; - {name = "foo"; value = Ident "baaaaaaaaaaaaaaaaar"}; - ] - -let _ = - CodePrinter.genOak oak {CodePrinter.emptyContext with max_line_length = 20} - |> CodePrinter.dump |> Format.printf "%s\n" -*) \ No newline at end of file From a37f17f9bb51b763e53bedf5d958ea3c55d17bb8 Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 16 Oct 2024 12:16:29 +0200 Subject: [PATCH 22/24] Inline isFunction check --- tools/src/tools.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/tools/src/tools.ml b/tools/src/tools.ml index a2134602f..d24be8387 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -361,15 +361,11 @@ let splitLast l = in splitLast' [] l -let isFunction = function - | Path.Pident {name = "function$"} -> true - | _ -> false - let valueDetail (typ : Types.type_expr) = let rec collectSignatureTypes (typ_desc : Types.type_desc) = match typ_desc with | Tlink t -> collectSignatureTypes t.desc - | Tconstr (path, [t; _], _) when isFunction path -> + | Tconstr (Path.Pident {name = "function$"}, [t; _], _) -> collectSignatureTypes t.desc | Tconstr (path, ts, _) -> ( let p = Print_tast.Transform.path_to_string path in From 09088d6e268e1c983607ca8f0e85450cc9bb6e3c Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 16 Oct 2024 12:18:54 +0200 Subject: [PATCH 23/24] Update help --- tools/bin/main.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/tools/bin/main.ml b/tools/bin/main.ml index 633b0b61b..61d0ba764 100644 --- a/tools/bin/main.ml +++ b/tools/bin/main.ml @@ -14,7 +14,8 @@ Usage: rescript-tools [command] Commands: -doc Generate documentation +doc Generate documentation +dump Dump the TAST of a file reanalyze Reanalyze -v, --version Print version -h, --help Print help|} From 339eb3a009f91e1243ee47372509e02ab879bcc3 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 17 Oct 2024 09:27:54 +0200 Subject: [PATCH 24/24] Refactor infix operator --- tools/src/prettier_printer.ml | 82 +++++++++++++++++++++++------------ 1 file changed, 54 insertions(+), 28 deletions(-) diff --git a/tools/src/prettier_printer.ml b/tools/src/prettier_printer.ml index 118024c54..a19abe784 100644 --- a/tools/src/prettier_printer.ml +++ b/tools/src/prettier_printer.ml @@ -120,12 +120,21 @@ module CodePrinter = struct |> updateMode false (** compose two context transforming functions *) - let ( +> ) f g ctx = + let compose_aux f g ctx = let fCtx = f ctx in match fCtx.mode with | ConfirmedMultiline -> fCtx | _ -> g fCtx + let compose (fs : appendEvents list) ctx = + let rec visit fs = + match fs with + | [] -> id + | [f] -> f + | f :: g :: rest -> visit (compose_aux f g :: rest) + in + visit fs ctx + let sepNln ctx = { ctx with @@ -145,7 +154,7 @@ module CodePrinter = struct let sepOpenL ctx = write "[" ctx let sepCloseL ctx = write "]" ctx let sepEq ctx = write " = " ctx - let wrapInParentheses f = sepOpenT +> f +> sepCloseT + let wrapInParentheses f = compose [sepOpenT; f; sepCloseT] let indent ctx = let nextIdent = ctx.current_indent + ctx.indent_size in { @@ -163,7 +172,7 @@ module CodePrinter = struct events = UnindentBy ctx.indent_size :: ctx.events; } - let indentAndNln f = indent +> sepNln +> f +> unindent + let indentAndNln f = compose [indent; sepNln; f; unindent] let col (f : 't -> appendEvents) (intertwine : appendEvents) items ctx = let rec visit items ctx = @@ -171,7 +180,7 @@ module CodePrinter = struct | [] -> ctx | [item] -> f item ctx | item :: rest -> - let ctx' = (f item +> intertwine) ctx in + let ctx' = compose [f item; intertwine] ctx in visit rest ctx' in visit items ctx @@ -203,29 +212,42 @@ module CodePrinter = struct | List xs -> genList xs and genApplication (name : string) (argument : oak) : appendEvents = - let short = write name +> sepOpenT +> genOak argument +> sepCloseT in + let short = compose [write name; sepOpenT; genOak argument; sepCloseT] in let long = - write name +> sepOpenT - +> (match argument with - | List _ | Record _ -> genOak argument - | _ -> indentAndNln (genOak argument) +> sepNln) - +> sepCloseT + compose + [ + write name; + sepOpenT; + (match argument with + | List _ | Record _ -> genOak argument + | _ -> compose [indentAndNln (genOak argument); sepNln]); + sepCloseT; + ] in expressionFitsOnRestOfLine short long and genRecord (recordFields : namedField list) : appendEvents = let short = match recordFields with - | [] -> sepOpenR +> sepCloseR + | [] -> compose [sepOpenR; sepCloseR] | fields -> - sepOpenR +> sepSpace - +> col genNamedField sepSemi fields - +> sepSpace +> sepCloseR + compose + [ + sepOpenR; + sepSpace; + col genNamedField sepSemi fields; + sepSpace; + sepCloseR; + ] in let long = - sepOpenR - +> indentAndNln (col genNamedField sepNln recordFields) - +> sepNln +> sepCloseR + compose + [ + sepOpenR; + indentAndNln (col genNamedField sepNln recordFields); + sepNln; + sepCloseR; + ] in expressionFitsOnRestOfLine short long @@ -239,16 +261,19 @@ module CodePrinter = struct and genNamedField (field : namedField) : appendEvents = let genValue = match field.value with - | Tuple _ -> sepOpenT +> genOak field.value +> sepCloseT + | Tuple _ -> compose [sepOpenT; genOak field.value; sepCloseT] | _ -> genOak field.value in - let short = write (field.name) +> sepEq +> genValue in + let short = compose [write field.name; sepEq; genValue] in let long = - write (field.name) +> sepEq - +> - match field.value with - | List _ | Record _ -> genOak field.value - | _ -> indentAndNln genValue + compose + [ + write field.name; + sepEq; + (match field.value with + | List _ | Record _ -> genOak field.value + | _ -> indentAndNln genValue); + ] in expressionFitsOnRestOfLine short long @@ -259,13 +284,14 @@ module CodePrinter = struct in let short = match items with - | [] -> sepOpenL +> sepCloseL + | [] -> compose [sepOpenL; sepCloseL] | _ -> - sepOpenL +> sepSpace +> col genItem sepSemi items +> sepSpace - +> sepCloseL + compose + [sepOpenL; sepSpace; col genItem sepSemi items; sepSpace; sepCloseL] in let long = - sepOpenL +> indentAndNln (col genItem sepNln items) +> sepNln +> sepCloseL + compose + [sepOpenL; indentAndNln (col genItem sepNln items); sepNln; sepCloseL] in expressionFitsOnRestOfLine short long end