From c0d1c04615ea44fff808a8254b21b4dce6305a86 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Dec 2020 14:06:33 +0100 Subject: [PATCH 1/2] Vendor and hook up the outcome printer from the syntax repo. Fixes https://github.com/rescript-lang/rescript-editor-support/issues/33 - Vendor the ourcome printer from https://github.com/rescript-lang/syntax - Make monads ppx use 406 AST to compile the vendored code (inline records) - Pass around / calculate recursion status to correctly print multiple and recursive type definitions. --- Changes.md | 1 + examples/example-project/src/ZZ.res | 29 + src/ppx/Ppx_Monads.re | 6 +- src/ppx/dune | 2 +- src/rescript-editor-support/Hover.re | 4 +- .../MessageHandlers.re | 2 +- src/rescript-editor-support/PrintType.re | 300 +---- src/rescript-editor-support/ProcessCmt.re | 43 +- src/rescript-editor-support/Shared.re | 6 +- src/rescript-editor-support/SharedTypes.re | 2 +- .../res_character_codes.ml | 160 +++ .../vendor/res_outcome_printer/res_comment.ml | 73 ++ .../res_outcome_printer/res_comment.mli | 17 + .../vendor/res_outcome_printer/res_doc.ml | 327 +++++ .../vendor/res_outcome_printer/res_doc.mli | 63 + .../res_outcome_printer/res_minibuffer.ml | 50 + .../res_outcome_printer/res_minibuffer.mli | 6 + .../res_outcome_printer.ml | 1117 +++++++++++++++++ .../vendor/res_outcome_printer/res_token.ml | 223 ++++ 19 files changed, 2124 insertions(+), 307 deletions(-) create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_character_codes.ml create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_comment.ml create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_comment.mli create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_doc.ml create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_doc.mli create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.ml create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.mli create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_outcome_printer.ml create mode 100644 src/rescript-editor-support/vendor/res_outcome_printer/res_token.ml diff --git a/Changes.md b/Changes.md index 68650991..ccb48353 100644 --- a/Changes.md +++ b/Changes.md @@ -5,6 +5,7 @@ - Remove semicolon in module top level preview. - Support syntax highlight in hover fenced blocks. - Fix printing of variant arguments. +- Use outcome printer from the syntax to print type declarations. ## Release 1.0.0 of rescript-vscode This [commit](https://github.com/rescript-lang/rescript-editor-support/commit/d45f45793a307a3bb87dcac0542fd412669f1b6e) is vendored in [rescript-vscode 1.0.0](https://github.com/rescript-lang/rescript-vscode/releases/tag/1.0.0). diff --git a/examples/example-project/src/ZZ.res b/examples/example-project/src/ZZ.res index 26f8a3c0..39e03083 100644 --- a/examples/example-project/src/ZZ.res +++ b/examples/example-project/src/ZZ.res @@ -37,3 +37,32 @@ type inline = | D({x: int, y: string}) | E({x: int, y: string}) | F + +module MSig +: { + type rec t = | A (list) + and s = list + + let x : int +} += { + type rec t = | A (list) + and s = list + + let x = 14 +} + +module Impl = { + type rec t = | A (list) + and s = list + + type w = int + + let x = 14 +} + +module Impl2 = { include Impl}; + +module D = MSig +module E = Impl +module F = Impl2 \ No newline at end of file diff --git a/src/ppx/Ppx_Monads.re b/src/ppx/Ppx_Monads.re index dd5c719b..a520969f 100644 --- a/src/ppx/Ppx_Monads.re +++ b/src/ppx/Ppx_Monads.re @@ -48,7 +48,7 @@ the result of the whole thing to be unit, use `let%consume`. */ open Migrate_parsetree -open OCaml_402.Ast +open OCaml_406.Ast /*** * https://ocsigen.org/lwt/dev/api/Ppx_lwt @@ -154,7 +154,7 @@ let mapper = Ast_helper.Exp.attr( [%expr [%e front]([%e mapper.expr(mapper, expr)], ~f=([%p pat]) => [%e mapper.expr(mapper, continuation)])], ({txt: "ocaml.explanation", loc}, PStr([ - Ast_helper.Str.eval(Ast_helper.Exp.constant(Const_string(explanation, None))) + Ast_helper.Str.eval(Ast_helper.Exp.constant(Pconst_string(explanation, None))) ])) ) } @@ -162,4 +162,4 @@ let mapper = } }; -let () = Driver.register(~name="ppx_monads", ~args=[], Versions.ocaml_402, (_config, _cookies) => mapper); \ No newline at end of file +let () = Driver.register(~name="ppx_monads", ~args=[], Versions.ocaml_406, (_config, _cookies) => mapper); \ No newline at end of file diff --git a/src/ppx/dune b/src/ppx/dune index cd935f22..83b14701 100644 --- a/src/ppx/dune +++ b/src/ppx/dune @@ -3,6 +3,6 @@ (name Ppx_monads) (flags :standard -w -9) (libraries compiler-libs ocaml-migrate-parsetree ppx_tools_versioned) - (preprocess (pps ppx_tools_versioned.metaquot_402)) + (preprocess (pps ppx_tools_versioned.metaquot_406)) (kind ppx_rewriter)) diff --git a/src/rescript-editor-support/Hover.re b/src/rescript-editor-support/Hover.re index 86b78937..2aaad495 100644 --- a/src/rescript-editor-support/Hover.re +++ b/src/rescript-editor-support/Hover.re @@ -30,8 +30,8 @@ let showModuleTopLevel = |> List.map(item => switch (item.SharedTypes.item) { /*** TODO pretty print module contents */ - | SharedTypes.MType({decl}) => - " " ++ (decl |> Shared.declToString(item.name.txt)) + | SharedTypes.MType({decl}, recStatus) => + " " ++ (decl |> Shared.declToString(~recStatus, item.name.txt)) | Module(_) => " module " ++ item.name.txt | MValue(typ) => " let " ++ item.name.txt ++ ": " ++ (typ |> Shared.typeToString) /* TODO indent */ diff --git a/src/rescript-editor-support/MessageHandlers.re b/src/rescript-editor-support/MessageHandlers.re index 09dd6778..9b6344c3 100644 --- a/src/rescript-editor-support/MessageHandlers.re +++ b/src/rescript-editor-support/MessageHandlers.re @@ -721,7 +721,7 @@ let handlers: let (item, siblings) = switch (item) { | MValue(v) => (v |> Shared.variableKind, []) - | MType(t) => (t.decl |> Shared.declarationKind, []) + | MType(t, _) => (t.decl |> Shared.declarationKind, []) | Module(Structure(contents)) => (Module, getItems(contents)) | Module(Ident(_)) => (Module, []) }; diff --git a/src/rescript-editor-support/PrintType.re b/src/rescript-editor-support/PrintType.re index 47305085..c1197754 100644 --- a/src/rescript-editor-support/PrintType.re +++ b/src/rescript-editor-support/PrintType.re @@ -1,287 +1,23 @@ -let rescript = ref(true); - -let rec dig = typ => - switch (typ.Types.desc) { - | Types.Tlink(inner) => dig(inner) - | Types.Tsubst(inner) => dig(inner) - | Types.Tpoly(inner, _) => dig(inner) - | _ => typ - }; - -let rec collectArgs = (coll, typ) => - switch (typ.Types.desc) { - | Types.Tarrow(label, arg, result, _) => - collectArgs([(label, arg), ...coll], result) - | Tlink(inner) => collectArgs(coll, inner) - | Tsubst(inner) => collectArgs(coll, inner) - | _ => (coll, typ) - }; - -let break = Pretty.line(""); -let space = Pretty.line(" "); -let dedent = Pretty.back(2, ""); - -let str = (~len=?, s) => Pretty.text(~len?, s); -let (+++) = Pretty.append; - -let sepdList = (sep, items, printItem) => { - let rec recur = items => - switch (items) { - | [] => Pretty.empty - | [one] => printItem(one) - | [one, ...more] => - let l = printItem(one); - l +++ sep +++ recur(more); - }; - recur(items); -}; - -let commadList = (printItem, items) => { - sepdList(str(",") +++ space, items, printItem); -}; - -let indentGroup = doc => Pretty.indent(2, Pretty.group(doc)); - -let tupleList = (items, printItem) => { - str("(") - +++ indentGroup(break +++ commadList(printItem, items) +++ dedent) - +++ str(")"); -}; - -let typeConstr = (items, printItem) => - if (rescript^) { - str("<") - +++ indentGroup(break +++ commadList(printItem, items) +++ dedent) - +++ str(">"); - } else { - tupleList(items, printItem); - }; - -let showArgs = (loop, args) => { - str("(") - +++ indentGroup( - break - +++ commadList( - ((label, typ)) => { - switch (label) { - | Asttypes.Nolabel => loop(typ) - | Labelled(label) - | Optional(label) => str("~" ++ label ++ ": ") +++ loop(typ) - } - }, - args, - ) - +++ dedent, - ) - +++ str(")"); -}; - -type namer = { - reset: unit => unit, - get: Types.type_expr => string, -}; -let makeNamer = () => { - let alphabet = "abcdefghijklmnopqrstuvwxyz"; - let latest = ref(0); - let names = Hashtbl.create(10); - let newName = () => { - let i = latest^; - latest := i + 1; - let num = i > 25 ? "t" ++ string_of_int(i) : String.sub(alphabet, i, 1); - "'" ++ num; - }; - let get = t => - try(Hashtbl.find(names, t)) { - | Not_found => - let name = newName(); - Hashtbl.replace(names, t, name); - name; - }; - let reset = () => { - latest := 0; - Hashtbl.clear(names); - }; - {get, reset}; -}; - -let namer = makeNamer(); - -let ident = id => str(Ident.name(id)); - -let rec print_expr = (~depth=0, typ) => { - /* Log.log("print_expr"); */ - let innerExpr = print_expr(~depth=depth + 1); - if (depth > 20) { - str("Too deep"); - } else { - Types.( - switch (typ.desc) { - | Tvar(None) => str(namer.get(typ)) - | Tvar(Some(s)) => str("'" ++ s) - | Tarrow(label, arg, result, _) => - let (args, result) = collectArgs([(label, arg)], result); - let args = List.rev(args); - ( - switch (args) { - | [(Nolabel, typ)] => - switch (dig(typ)) { - | {desc: Ttuple(_)} => showArgs(innerExpr, args) - | _ => innerExpr(typ) - } - | _ => showArgs(innerExpr, args) - } - ) - +++ str(" => ") - +++ innerExpr(result); - | Ttuple(items) => tupleList(items, innerExpr) - | Tconstr(path, args, _) => - print_path(path) - +++ ( - switch (args) { - | [] => Pretty.empty - | args => typeConstr(args, innerExpr) - } - ) - | Tlink(inner) => innerExpr(inner) - | Tsubst(inner) => innerExpr(inner) - | Tnil => str("(no type)") - | Tvariant({row_fields}) => - str("[") - +++ indentGroup( - break - +++ (List.length(row_fields) <= 1 ? str("| ") : str(" ")) - +++ sepdList( - space +++ str("| "), row_fields, ((label, row_field)) => - switch (row_field) { - | Rpresent(None) - | Reither(_, [], _, _) => str("#" ++ label) - | Rpresent(Some(t)) - | Reither(_, [t], _, _) => - str("#" ++ label) - +++ str("(") - +++ innerExpr(t) - +++ str(")") - | Reither(_) - | Rabsent => str("...") - } - ), - ) - +++ str("]") - +++ break - | Tfield(_, _, _, _) - | Tunivar(_) - | Tpoly(_, _) - | Tpackage(_, _, _) - | Tobject(_, _) => - let txt = { - try(Printtyp.type_expr(Format.str_formatter, typ)) { - | _ => Format.fprintf(Format.str_formatter, "Unable to print type") - }; - Format.flush_str_formatter(); - }; - str(txt); - } - ); - }; -} - -and print_path = path => - switch (path) { - | Path.Pident(id) => ident(id) - | Pdot(path, name, _) => print_path(path) +++ str("." ++ name) - | Papply(_, _) => str("") +let printExpr = typ => { + try( + Res_outcome_printer.printOutType( + Format.str_formatter, + Printtyp.tree_of_typexp(false, typ), + ) + ) { + | _ => Format.fprintf(Format.str_formatter, "Unable to print type") }; - -let print_attr = ({Types.ld_id, ld_mutable, ld_type}) => { - ( - switch (ld_mutable) { - | Asttypes.Immutable => Pretty.empty - | Mutable => str("mutable ") - } - ) - +++ ident(ld_id) - +++ str(": ") - +++ print_expr(ld_type); + Format.flush_str_formatter(); }; -let print_constructor = (loop, {Types.cd_id, cd_args, cd_res}) => { - let name = Ident.name(cd_id); - str(name) - +++ ( - switch (cd_args) { - | Cstr_tuple([]) => Pretty.empty - | Cstr_record(labels) => - str("({") - +++ indentGroup( - indentGroup(break +++ commadList(print_attr, labels) +++ dedent), - ) - +++ str("})") - | Cstr_tuple(args) => tupleList(args, loop) - } - ) - +++ ( - switch (cd_res) { - | None => Pretty.empty - | Some(typ) => str(": ") +++ loop(typ) - } - ); -}; - -let print_decl = (realName, name, decl) => { - Types.( - str("type ") - +++ str(~len=String.length(realName), name) - +++ ( - switch (decl.type_params) { - | [] => Pretty.empty - | args => typeConstr(args, print_expr) - } - ) - +++ ( - switch (decl.type_kind) { - | Type_abstract => Pretty.empty - | Type_open => str(" = ..") - | Type_record(labels, _representation) => - str(" = {") - +++ indentGroup(break +++ commadList(print_attr, labels) +++ dedent) - +++ str("}") - | Type_variant(constructors) => - str(" = ") - +++ indentGroup( - break - +++ str("| ") - +++ sepdList( - space +++ str("| "), - constructors, - print_constructor(print_expr), - ), - ) - +++ break - } +let printDecl = (~recStatus, name, decl) => { + try( + Res_outcome_printer.printOutSigItem( + Format.str_formatter, + Printtyp.tree_of_type_declaration(Ident.create(name), decl, recStatus), ) - +++ ( - switch (decl.type_manifest) { - | None => Pretty.empty - | Some(manifest) => str(" = ") +++ print_expr(manifest) - } - ) - ); -}; - -let prettyString = (~width=60, doc) => { - namer.reset(); - let buffer = Buffer.create(100); - Pretty.print( - ~width, - ~output=text => Buffer.add_string(buffer, text), - ~indent= - num => { - Buffer.add_string(buffer, "\n"); - for (_ in 1 to num) { - Buffer.add_char(buffer, ' '); - }; - }, - doc, - ); - Buffer.contents(buffer); + ) { + | _ => Format.fprintf(Format.str_formatter, "Unable to print type") + }; + Format.flush_str_formatter(); }; diff --git a/src/rescript-editor-support/ProcessCmt.re b/src/rescript-editor-support/ProcessCmt.re index 654fa02f..ac398100 100644 --- a/src/rescript-editor-support/ProcessCmt.re +++ b/src/rescript-editor-support/ProcessCmt.re @@ -93,7 +93,7 @@ let rec forSignatureTypeItem = (env, exported: SharedTypes.exported, item) => { | Sig_type( ident, {type_loc, type_kind, type_manifest, type_attributes} as decl, - _, + recStatus, ) => let declared = addItem( @@ -175,7 +175,7 @@ let rec forSignatureTypeItem = (env, exported: SharedTypes.exported, item) => { exported.types, env.stamps.types, ); - [{...declared, item: MType(declared.item)}]; + [{...declared, item: MType(declared.item, recStatus)}]; /* | Sig_module({stamp, name}, {md_type: Mty_ident(path) | Mty_alias(path), md_attributes, md_loc}, _) => let declared = addItem(~contents=Module.Ident(path), ~name=Location.mknoloc(name), ~stamp, ~env, md_attributes, exported.modules, env.stamps.modules); [{...declared, contents: Module.Module(declared.contents)}, ...items] */ @@ -204,9 +204,7 @@ and forSignatureType = (env, signature) => { (item, items) => {forSignatureTypeItem(env, exported, item) @ items}, signature, [], - ) - |> List.rev; - + ); {exported, topLevel}; } and forModuleType = (env, moduleType) => @@ -241,6 +239,7 @@ let forTypeDeclaration = typ_kind, typ_manifest, }, + ~recStatus, ) => { let stamp = Ident.binding_time(typ_id); let declared = @@ -298,7 +297,7 @@ let forTypeDeclaration = exported.types, env.stamps.types, ); - {...declared, item: MType(declared.item)}; + {...declared, item: MType(declared.item, recStatus)}; }; let forSignatureItem = (~env, ~exported: exported, item) => { @@ -316,8 +315,17 @@ let forSignatureItem = (~env, ~exported: exported, item) => { env.stamps.values, ); [{...declared, item: MValue(declared.item)}]; - | Tsig_type(_ /*402*/, decls) => - decls |> List.map(forTypeDeclaration(~env, ~exported)) + | Tsig_type(recFlag, decls) => + decls + |> List.mapi((i, decl) => { + let recStatus = + switch (recFlag) { + | Recursive when i == 0 => Types.Trec_first + | Nonrecursive when i == 0 => Types.Trec_not + | _ => Types.Trec_next + }; + decl |> forTypeDeclaration(~env, ~exported, ~recStatus); + }) | Tsig_module({ md_id, md_attributes, @@ -352,8 +360,7 @@ let forSignatureItem = (~env, ~exported: exported, item) => { (item, items) => {forSignatureTypeItem(env, exported, item) @ items}, incl_type, [], - ) - |> List.rev; + ); topLevel; /* TODO: process other things here */ @@ -447,8 +454,7 @@ let rec forItem = (~env, ~exported: exported, item) => (item, items) => {forSignatureTypeItem(env, exported, item) @ items}, incl_type, [], - ) - |> List.rev; + ); topLevel; @@ -471,8 +477,17 @@ let rec forItem = (~env, ~exported: exported, item) => env.stamps.values, ); [{...declared, item: MValue(declared.item)}]; - | Tstr_type(_, decls) => - decls |> List.map(forTypeDeclaration(~env, ~exported)) + | Tstr_type(recFlag, decls) => + decls + |> List.mapi((i, decl) => { + let recStatus = + switch (recFlag) { + | Recursive when i == 0 => Types.Trec_first + | Nonrecursive when i == 0 => Types.Trec_not + | _ => Types.Trec_next + }; + decl |> forTypeDeclaration(~env, ~exported, ~recStatus); + }) | _ => [] } diff --git a/src/rescript-editor-support/Shared.re b/src/rescript-editor-support/Shared.re index e98480cd..941368b9 100644 --- a/src/rescript-editor-support/Shared.re +++ b/src/rescript-editor-support/Shared.re @@ -68,8 +68,8 @@ let declarationKind = t => | Type_variant(_) => Enum }; -let declToString = (name, t) => - PrintType.print_decl(name, name, t) |> PrintType.prettyString; +let declToString = (~recStatus=Types.Trec_not, name, t) => + PrintType.printDecl(~recStatus, name, t); let labelToString = label => switch (label) { @@ -84,7 +84,7 @@ let typeTbl = Hashtbl.create(1); let typeToString = (t: Types.type_expr) => { switch (cacheTypeToString^ ? Hashtbl.find_opt(typeTbl, (t.id, t)) : None) { | None => - let s = PrintType.print_expr(t) |> PrintType.prettyString(~width=40); + let s = PrintType.printExpr(t); Hashtbl.replace(typeTbl, (t.id, t), s); s; | Some(s) => s diff --git a/src/rescript-editor-support/SharedTypes.re b/src/rescript-editor-support/SharedTypes.re index 27e795d5..537c5800 100644 --- a/src/rescript-editor-support/SharedTypes.re +++ b/src/rescript-editor-support/SharedTypes.re @@ -138,7 +138,7 @@ let initExported = () => { }; type moduleItem = | MValue(Types.type_expr) - | MType(Type.t) + | MType(Type.t, Types.rec_status) | Module(moduleKind) and moduleContents = { exported, diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_character_codes.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_character_codes.ml new file mode 100644 index 00000000..aec713a7 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_character_codes.ml @@ -0,0 +1,160 @@ +let eof = -1 + +let space = 0x0020 +let newline = 0x0A (* \n *) [@@live] +let lineFeed = 0x0A (* \n *) +let carriageReturn = 0x0D (* \r *) +let lineSeparator = 0x2028 +let paragraphSeparator = 0x2029 + +let tab = 0x09 + +let bang = 0x21 +let dot = 0x2E +let colon = 0x3A +let comma = 0x2C +let backtick = 0x60 +(* let question = 0x3F *) +let semicolon = 0x3B +let underscore = 0x5F +let singleQuote = 0x27 +let doubleQuote = 0x22 +let equal = 0x3D +let bar = 0x7C +let tilde = 0x7E +let question = 0x3F +let ampersand = 0x26 +let at = 0x40 +let dollar = 0x24 +let percent = 0x25 + +let lparen = 0x28 +let rparen = 0x29 +let lbracket = 0x5B +let rbracket = 0x5D +let lbrace = 0x7B +let rbrace = 0x7D + +let forwardslash = 0x2F (* / *) +let backslash = 0x5C (* \ *) + +let greaterThan = 0x3E +let hash = 0x23 +let lessThan = 0x3C + +let minus = 0x2D +let plus = 0x2B +let asterisk = 0x2A + +let _0 = 0x30 +let _1 = 0x31 [@@live] +let _2 = 0x32 [@@live] +let _3 = 0x33 [@@live] +let _4 = 0x34 [@@live] +let _5 = 0x35 [@@live] +let _6 = 0x36 [@@live] +let _7 = 0x37 [@@live] +let _8 = 0x38 [@@live] +let _9 = 0x39 + +module Lower = struct + let a = 0x61 + let b = 0x62 + let c = 0x63 [@@live] + let d = 0x64 [@@live] + let e = 0x65 + let f = 0x66 + let g = 0x67 + let h = 0x68 [@@live] + let i = 0x69 [@@live] + let j = 0x6A [@@live] + let k = 0x6B [@@live] + let l = 0x6C [@@live] + let m = 0x6D [@@live] + let n = 0x6E + let o = 0x6F + let p = 0x70 + let q = 0x71 [@@live] + let r = 0x72 + let s = 0x73 [@@live] + let t = 0x74 + let u = 0x75 [@@live] + let v = 0x76 [@@live] + let w = 0x77 [@@live] + let x = 0x78 + let y = 0x79 [@@live] + let z = 0x7A +end + +module Upper = struct + let a = 0x41 + (* let b = 0x42 *) + let c = 0x43 [@@live] + let d = 0x44 [@@live] + let e = 0x45 [@@live] + let f = 0x46 [@@live] + let g = 0x47 + let h = 0x48 [@@live] + let i = 0x49 [@@live] + let j = 0x4A [@@live] + let k = 0x4B [@@live] + let l = 0x4C [@@live] + let m = 0x4D [@@live] + let b = 0x4E [@@live] + let o = 0x4F [@@live] + let p = 0x50 [@@live] + let q = 0x51 [@@live] + let r = 0x52 [@@live] + let s = 0x53 [@@live] + let t = 0x54 [@@live] + let u = 0x55 [@@live] + let v = 0x56 [@@live] + let w = 0x57 [@@live] + let x = 0x58 [@@live] + let y = 0x59 [@@live] + let z = 0x5a +end + +(* returns lower-case ch, ch should be ascii *) +let lower ch = + (* if ch >= Lower.a && ch <= Lower.z then ch else ch + 32 *) + 32 lor ch + +let isLetter ch = + Lower.a <= ch && ch <= Lower.z || + Upper.a <= ch && ch <= Upper.z + +let isUpperCase ch = + Upper.a <= ch && ch <= Upper.z + +let isDigit ch = _0 <= ch && ch <= _9 + +let isHex ch = + (_0 <= ch && ch <= _9) || + (Lower.a <= (lower ch) && (lower ch) <= Lower.f) + + (* + // ES5 7.3: + // The ECMAScript line terminator characters are listed in Table 3. + // Table 3: Line Terminator Characters + // Code Unit Value Name Formal Name + // \u000A Line Feed + // \u000D Carriage Return + // \u2028 Line separator + // \u2029 Paragraph separator + // Only the characters in Table 3 are treated as line terminators. Other new line or line + // breaking characters are treated as white space but not as line terminators. +*) +let isLineBreak ch = + ch == lineFeed + || ch == carriageReturn + || ch == lineSeparator + || ch == paragraphSeparator + +let digitValue ch = + if _0 <= ch && ch <= _9 then + ch - 48 + else if Lower.a <= (lower ch) && (lower ch) <= Lower.f then + (lower ch) - Lower.a + 10 + else + 16 (* larger than any legal value *) diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.ml new file mode 100644 index 00000000..a582dcda --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.ml @@ -0,0 +1,73 @@ +type style = + | SingleLine + | MultiLine + +let styleToString s = match s with + | SingleLine -> "SingleLine" + | MultiLine -> "MultiLine" + +type t = { + txt: string; + style: style; + loc: Location.t; + mutable prevTokEndPos: Lexing.position; +} + +let loc t = t.loc +let txt t = t.txt +let prevTokEndPos t = t.prevTokEndPos + +let setPrevTokEndPos t pos = + t.prevTokEndPos <- pos + +let isSingleLineComment t = match t.style with + | SingleLine -> true + | MultiLine -> false + +let toString t = + Format.sprintf + "(txt: %s\nstyle: %s\nlines: %d-%d)" + t.txt + (styleToString t.style) + t.loc.loc_start.pos_lnum + t.loc.loc_end.pos_lnum + +let makeSingleLineComment ~loc txt = { + txt; + loc; + style = SingleLine; + prevTokEndPos = Lexing.dummy_pos; +} + +let makeMultiLineComment ~loc txt = { + txt; + loc; + style = MultiLine; + prevTokEndPos = Lexing.dummy_pos; +} + +let fromOcamlComment ~loc ~txt ~prevTokEndPos = { + txt; + loc; + style = MultiLine; + prevTokEndPos = prevTokEndPos +} + +let trimSpaces s = + let len = String.length s in + if len = 0 then s + else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then ( + let b = Bytes.of_string s in + let i = ref 0 in + while !i < len && (Bytes.unsafe_get b !i) = ' ' do + incr i + done; + let j = ref (len - 1) in + while !j >= !i && (Bytes.unsafe_get b !j) = ' ' do + decr j + done; + if !j >= !i then + (Bytes.sub [@doesNotRaise]) b !i (!j - !i + 1) |> Bytes.to_string + else + "" + ) else s \ No newline at end of file diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.mli b/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.mli new file mode 100644 index 00000000..7fdaa045 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_comment.mli @@ -0,0 +1,17 @@ +type t + +val toString: t -> string + +val loc: t -> Location.t +val txt: t -> string +val prevTokEndPos: t -> Lexing.position + +val setPrevTokEndPos: t -> Lexing.position -> unit + +val isSingleLineComment: t -> bool + +val makeSingleLineComment: loc:Location.t -> string -> t +val makeMultiLineComment: loc:Location.t -> string -> t +val fromOcamlComment: + loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t +val trimSpaces: string -> string \ No newline at end of file diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.ml new file mode 100644 index 00000000..688b8db3 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.ml @@ -0,0 +1,327 @@ +module MiniBuffer = Res_minibuffer + +type mode = Break | Flat + +type lineStyle = + | Classic (* fits? -> replace with space *) + | Soft (* fits? -> replaced with nothing *) + | Hard (* always included, forces breaks in parents *) + (* always included, forces breaks in parents, but doesn't increase indentation + use case: template literals, multiline string content *) + | Literal + +type t = + | Nil + | Text of string + | Concat of t list + | Indent of t + | IfBreaks of {yes: t; no: t} + | LineSuffix of t + | LineBreak of lineStyle + | Group of {shouldBreak: bool; doc: t} + | CustomLayout of t list + | BreakParent + +let nil = Nil +let line = LineBreak Classic +let hardLine = LineBreak Hard +let softLine = LineBreak Soft +let literalLine = LineBreak Literal +let text s = Text s +let concat l = Concat l +let indent d = Indent d +let ifBreaks t f = IfBreaks {yes = t; no = f} +let lineSuffix d = LineSuffix d +let group d = Group {shouldBreak = false; doc = d} +let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} +let customLayout gs = CustomLayout gs +let breakParent = BreakParent + +let space = Text " " +let comma = Text "," +let dot = Text "." +let dotdot = Text ".." +let dotdotdot = Text "..." +let lessThan = Text "<" +let greaterThan = Text ">" +let lbrace = Text "{" +let rbrace = Text "}" +let lparen = Text "(" +let rparen = Text ")" +let lbracket = Text "[" +let rbracket = Text "]" +let question = Text "?" +let tilde = Text "~" +let equal = Text "=" +let trailingComma = IfBreaks {yes = comma; no = nil} +let doubleQuote = Text "\"" + +let propagateForcedBreaks doc = + let rec walk doc = match doc with + | Text _ | Nil | LineSuffix _ -> + (false, doc) + | BreakParent -> + (true, Nil) + | LineBreak (Hard | Literal) -> + (true, doc) + | LineBreak (Classic | Soft) -> + (false, doc) + | Indent children -> + let (childForcesBreak, newChildren) = walk children in + (childForcesBreak, Indent newChildren) + | IfBreaks {yes = trueDoc; no = falseDoc} -> + let (falseForceBreak, falseDoc) = walk falseDoc in + if falseForceBreak then + let (_, trueDoc) = walk trueDoc in + (true, trueDoc) + else + let forceBreak, trueDoc = walk trueDoc in + (forceBreak, IfBreaks {yes = trueDoc; no = falseDoc}) + | Group {shouldBreak = forceBreak; doc = children} -> + let (childForcesBreak, newChildren) = walk children in + let shouldBreak = forceBreak || childForcesBreak in + (shouldBreak, Group {shouldBreak; doc = newChildren}) + | Concat children -> + let (forceBreak, newChildren) = List.fold_left (fun (forceBreak, newChildren) child -> + let (childForcesBreak, newChild) = walk child in + (forceBreak || childForcesBreak, newChild::newChildren) + ) (false, []) children + in + (forceBreak, Concat (List.rev newChildren)) + | CustomLayout children -> + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let children = match walk (Concat children) with + | (_, Concat children) -> children + | _ -> assert false + in + (false, CustomLayout children) + in + let (_, processedDoc) = walk doc in + processedDoc + +(* See documentation in interface file *) +let rec willBreak doc = match doc with + | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> true + | Group {doc} | Indent doc | CustomLayout (doc::_) -> willBreak doc + | Concat docs -> List.exists willBreak docs + | IfBreaks {yes; no} -> willBreak yes || willBreak no + | _ -> false + +let join ~sep docs = + let rec loop acc sep docs = + match docs with + | [] -> List.rev acc + | [x] -> List.rev (x::acc) + | x::xs -> loop (sep::x::acc) sep xs + in + Concat(loop [] sep docs) + +let rec fits w doc = match doc with + | _ when w < 0 -> false + | [] -> true + | (_ind, _mode, Text txt)::rest -> fits (w - String.length txt) rest + | (ind, mode, Indent doc)::rest -> fits w ((ind + 2, mode, doc)::rest) + | (_ind, Flat, LineBreak break)::rest -> + if break = Hard || break = Literal then true + else + let w = if break = Classic then w - 1 else w in + fits w rest + | (_ind, _mode, Nil)::rest -> fits w rest + | (_ind, Break, LineBreak _break)::_rest -> true + | (ind, mode, Group {shouldBreak = forceBreak; doc})::rest -> + let mode = if forceBreak then Break else mode in + fits w ((ind, mode, doc)::rest) + | (ind, mode, IfBreaks {yes = breakDoc; no = flatDoc})::rest -> + if mode = Break then + fits w ((ind, mode, breakDoc)::rest) + else + fits w ((ind, mode, flatDoc)::rest) + | (ind, mode, Concat docs)::rest -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + fits w (List.append ops rest) + (* | (_ind, _mode, Cursor)::rest -> fits w rest *) + | (_ind, _mode, LineSuffix _)::rest -> fits w rest + | (_ind, _mode, BreakParent)::rest -> fits w rest + | (ind, mode, CustomLayout (hd::_))::rest -> + (* TODO: if we have nested custom layouts, what we should do here? *) + fits w ((ind, mode, hd)::rest) + | (_ind, _mode, CustomLayout _)::rest -> + fits w rest + +let toString ~width doc = + let doc = propagateForcedBreaks doc in + let buffer = MiniBuffer.create 1000 in + + let rec process ~pos lineSuffices stack = + match stack with + | ((ind, mode, doc) as cmd)::rest -> + begin match doc with + | Nil | BreakParent -> + process ~pos lineSuffices rest + | Text txt -> + MiniBuffer.add_string buffer txt; + process ~pos:(String.length txt + pos) lineSuffices rest + | LineSuffix doc -> + process ~pos ((ind, mode, doc)::lineSuffices) rest + | Concat docs -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + process ~pos lineSuffices (List.append ops rest) + | Indent doc -> + process ~pos lineSuffices ((ind + 2, mode, doc)::rest) + | IfBreaks {yes = breakDoc; no = flatDoc} -> + if mode = Break then + process ~pos lineSuffices ((ind, mode, breakDoc)::rest) + else + process ~pos lineSuffices ((ind, mode, flatDoc)::rest) + | LineBreak lineStyle -> + if mode = Break then ( + begin match lineSuffices with + | [] -> + if lineStyle = Literal then ( + MiniBuffer.add_char buffer '\n'; + process ~pos:0 [] rest + ) else ( + MiniBuffer.flush_newline buffer; + MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); + process ~pos:ind [] rest + ) + | _docs -> + process ~pos:ind [] (List.concat [List.rev lineSuffices; cmd::rest]) + end + ) else (* mode = Flat *) ( + let pos = match lineStyle with + | Classic -> MiniBuffer.add_string buffer " "; pos + 1 + | Hard -> MiniBuffer.flush_newline buffer; 0 + | Literal -> MiniBuffer.add_char buffer '\n'; 0 + | Soft -> pos + in + process ~pos lineSuffices rest + ) + | Group {shouldBreak; doc} -> + if shouldBreak || not (fits (width - pos) ((ind, Flat, doc)::rest)) then + process ~pos lineSuffices ((ind, Break, doc)::rest) + else + process ~pos lineSuffices ((ind, Flat, doc)::rest) + | CustomLayout docs -> + let rec findGroupThatFits groups = match groups with + | [] -> Nil + | [lastGroup] -> lastGroup + | doc::docs -> + if (fits (width - pos) ((ind, Flat, doc)::rest)) then + doc + else + findGroupThatFits docs + in + let doc = findGroupThatFits docs in + process ~pos lineSuffices ((ind, Flat, doc)::rest) + end + | [] -> + begin match lineSuffices with + | [] -> () + | suffices -> + process ~pos:0 [] (List.rev suffices) + end + in + process ~pos:0 [] [0, Flat, doc]; + MiniBuffer.contents buffer + + +let debug t = + let rec toDoc = function + | Nil -> text "nil" + | BreakParent -> text "breakparent" + | Text txt -> text ("text(" ^ txt ^ ")") + | LineSuffix doc -> group( + concat [ + text "linesuffix("; + indent ( + concat [line; toDoc doc] + ); + line; + text ")" + ] + ) + | Concat docs -> group( + concat [ + text "concat("; + indent ( + concat [ + line; + join ~sep:(concat [text ","; line]) + (List.map toDoc docs) ; + ] + ); + line; + text ")" + ] + ) + | CustomLayout docs -> group( + concat [ + text "customLayout("; + indent ( + concat [ + line; + join ~sep:(concat [text ","; line]) + (List.map toDoc docs) ; + ] + ); + line; + text ")" + ] + ) + | Indent doc -> + concat [ + text "indent("; + softLine; + toDoc doc; + softLine; + text ")"; + ] + | IfBreaks {yes = trueDoc; no = falseDoc} -> + group( + concat [ + text "ifBreaks("; + indent ( + concat [ + line; + toDoc trueDoc; + concat [text ","; line]; + toDoc falseDoc; + ] + ); + line; + text ")" + ] + ) + | LineBreak break -> + let breakTxt = match break with + | Classic -> "Classic" + | Soft -> "Soft" + | Hard -> "Hard" + | Literal -> "Liteal" + in + text ("LineBreak(" ^ breakTxt ^ ")") + | Group {shouldBreak; doc} -> + group( + concat [ + text "Group("; + indent ( + concat [ + line; + text ("shouldBreak: " ^ (string_of_bool shouldBreak)); + concat [text ","; line]; + toDoc doc; + ] + ); + line; + text ")" + ] + ) + in + let doc = toDoc t in + toString ~width:10 doc |> print_endline + [@@live] diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.mli b/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.mli new file mode 100644 index 00000000..97348759 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_doc.mli @@ -0,0 +1,63 @@ +type t + +val nil: t +val line: t +val hardLine: t +val softLine: t +val literalLine: t +val text: string -> t +val concat: t list -> t +val indent: t -> t +val ifBreaks: t -> t -> t +val lineSuffix: t -> t +val group: t -> t +val breakableGroup: forceBreak : bool -> t -> t +(* `customLayout docs` will pick the layout that fits from `docs`. + * This is a very expensive computation as every layout from the list + * will be checked until one fits. *) +val customLayout: t list -> t +val breakParent: t +val join: sep: t -> t list -> t + +val space: t +val comma: t +val dot: t +val dotdot: t +val dotdotdot: t +val lessThan: t +val greaterThan: t +val lbrace: t +val rbrace: t +val lparen: t +val rparen: t +val lbracket: t +val rbracket: t +val question: t +val tilde: t +val equal: t +val trailingComma: t +val doubleQuote: t + +(* + * `willBreak doc` checks whether `doc` contains forced line breaks. + * This is more or less a "workaround" to make the parent of a `customLayout` break. + * Forced breaks are not propagated through `customLayout`; otherwise we would always + * get the last layout the algorithm tries… + * This might result into some weird layouts: + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * The `[` and `]` would be a lot better broken out. + * Although the layout of `fn(x => {...})` is correct, we need to break its parent (the array). + * `willBreak` can be used in this scenario to check if the `fn…` contains any forced breaks. + * The consumer can then manually insert a `breakParent` doc, to manually propagate the + * force breaks from bottom to top. + *) +val willBreak: t -> bool + +val toString: width: int -> t -> string +val debug: t -> unit [@@live] diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.ml new file mode 100644 index 00000000..43ba4334 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.ml @@ -0,0 +1,50 @@ +type t = { + mutable buffer : bytes; + mutable position : int; + mutable length : int; +} + +let create n = + let n = if n < 1 then 1 else n in + let s = (Bytes.create [@doesNotRaise]) n in + {buffer = s; position = 0; length = n} + +let contents b = Bytes.sub_string b.buffer 0 b.position + +(* Can't be called directly, don't add to the interface *) +let resize_internal b more = + let len = b.length in + let new_len = ref len in + while b.position + more > !new_len do new_len := 2 * !new_len done; + if !new_len > Sys.max_string_length then begin + if b.position + more <= Sys.max_string_length + then new_len := Sys.max_string_length + end; + let new_buffer = (Bytes.create [@doesNotRaise]) !new_len in + (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in + this tricky function that is slow anyway. *) + Bytes.blit b.buffer 0 new_buffer 0 b.position [@doesNotRaise]; + b.buffer <- new_buffer; + b.length <- !new_len + +let add_char b c = + let pos = b.position in + if pos >= b.length then resize_internal b 1; + Bytes.unsafe_set b.buffer pos c; + b.position <- pos + 1 + +let add_string b s = + let len = String.length s in + let new_position = b.position + len in + if new_position > b.length then resize_internal b len; + Bytes.blit_string s 0 b.buffer b.position len [@doesNotRaise]; + b.position <- new_position + +(* adds newline and trims all preceding whitespace *) +let flush_newline b = + let position = ref (b.position) in + while (Bytes.unsafe_get b.buffer (!position - 1)) = ' ' && !position >= 0 do + position := !position - 1; + done; + b.position <- !position; + add_char b '\n' diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.mli b/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.mli new file mode 100644 index 00000000..0a2bffa5 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_minibuffer.mli @@ -0,0 +1,6 @@ +type t +val add_char : t -> char -> unit +val add_string : t -> string -> unit +val contents : t -> string +val create : int -> t +val flush_newline : t -> unit diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_outcome_printer.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_outcome_printer.ml new file mode 100644 index 00000000..84070e26 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_outcome_printer.ml @@ -0,0 +1,1117 @@ +(* For the curious: the outcome printer is a printer to print data + * from the outcometree.mli file in the ocaml compiler. + * The outcome tree is used by: + * - ocaml's toplevel/repl, print results/errors + * - super errors, print nice errors + * - editor tooling, e.g. show type on hover + * + * In general it represent messages to show results or errors to the user. *) + +module Doc = Res_doc +module Token = Res_token + +type identifierStyle = + | ExoticIdent + | NormalIdent + +let classifyIdentContent ~allowUident txt = + let len = String.length txt in + let rec go i = + if i == len then NormalIdent + else + let c = String.unsafe_get txt i in + if i == 0 && not ( + (allowUident && (c >= 'A' && c <= 'Z')) || + (c >= 'a' && c <= 'z') || c = '_' || (c >= '0' && c <= '9')) then + ExoticIdent + else if not ( + (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || c = '\'' + || c = '_' + || (c >= '0' && c <= '9')) + then + ExoticIdent + else + go (i + 1) + in + if Token.isKeywordTxt txt then + ExoticIdent + else + go 0 + +let printIdentLike ~allowUident txt = + match classifyIdentContent ~allowUident txt with + | ExoticIdent -> Doc.concat [ + Doc.text "\\\""; + Doc.text txt; + Doc.text"\"" + ] + | NormalIdent -> Doc.text txt + + (* ReScript doesn't have parenthesized identifiers. + * We don't support custom operators. *) + let parenthesized_ident _name = true + + (* TODO: better allocation strategy for the buffer *) + let escapeStringContents s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + let c = (String.get [@doesNotRaise]) s i in + if c = '\008' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'b'; + ) else if c = '\009' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 't'; + ) else if c = '\010' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'n'; + ) else if c = '\013' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'r'; + ) else if c = '\034' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '"'; + ) else if c = '\092' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '\\'; + ) else ( + Buffer.add_char b c; + ); + done; + Buffer.contents b + + (* let rec print_ident fmt ident = match ident with + | Outcometree.Oide_ident s -> Format.pp_print_string fmt s + | Oide_dot (id, s) -> + print_ident fmt id; + Format.pp_print_char fmt '.'; + Format.pp_print_string fmt s + | Oide_apply (id1, id2) -> + print_ident fmt id1; + Format.pp_print_char fmt '('; + print_ident fmt id2; + Format.pp_print_char fmt ')' *) + + let rec printOutIdentDoc ?(allowUident=true) (ident : Outcometree.out_ident) = + match ident with + | Oide_ident s -> printIdentLike ~allowUident s + | Oide_dot (ident, s) -> Doc.concat [ + printOutIdentDoc ident; + Doc.dot; + Doc.text s; + ] + | Oide_apply (call, arg) ->Doc.concat [ + printOutIdentDoc call; + Doc.lparen; + printOutIdentDoc arg; + Doc.rparen; + ] + + let printOutAttributeDoc (outAttribute: Outcometree.out_attribute) = + Doc.concat [ + Doc.text "@"; + Doc.text outAttribute.oattr_name; + ] + + let printOutAttributesDoc (attrs: Outcometree.out_attribute list) = + match attrs with + | [] -> Doc.nil + | attrs -> + Doc.concat [ + Doc.group ( + Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs) + ); + Doc.line; + ] + + let rec collectArrowArgs (outType: Outcometree.out_type) args = + match outType with + | Otyp_arrow (label, argType, returnType) -> + let arg = (label, argType) in + collectArrowArgs returnType (arg::args) + | _ as returnType -> + (List.rev args, returnType) + + let rec collectFunctorArgs (outModuleType: Outcometree.out_module_type) args = + match outModuleType with + | Omty_functor (lbl, optModType, returnModType) -> + let arg = (lbl, optModType) in + collectFunctorArgs returnModType (arg::args) + | _ -> + (List.rev args, outModuleType) + + let rec printOutTypeDoc (outType: Outcometree.out_type) = + match outType with + | Otyp_abstract | Otyp_open -> Doc.nil + | Otyp_variant (nonGen, outVariant, closed, labels) -> + (* bool * out_variant * bool * (string list) option *) + let opening = match (closed, labels) with + | (true, None) -> (* [#A | #B] *) Doc.softLine + | (false, None) -> + (* [> #A | #B] *) + Doc.concat [Doc.greaterThan; Doc.line] + | (true, Some []) -> + (* [< #A | #B] *) + Doc.concat [Doc.lessThan; Doc.line] + | (true, Some _) -> + (* [< #A | #B > #X #Y ] *) + Doc.concat [Doc.lessThan; Doc.line] + | (false, Some _) -> + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) + Doc.concat [Doc.text "?"; Doc.line] + in + Doc.group ( + Doc.concat [ + if nonGen then Doc.text "_" else Doc.nil; + Doc.lbracket; + Doc.indent ( + Doc.concat [ + opening; + printOutVariant outVariant + ] + ); + begin match labels with + | None | Some [] -> Doc.nil + | Some tags -> + Doc.group ( + Doc.concat [ + Doc.space; + Doc.join ~sep:Doc.space ( + List.map (fun lbl -> printIdentLike ~allowUident:true lbl) tags + ) + ] + ) + end; + Doc.softLine; + Doc.rbracket; + ] + ) + | Otyp_alias (typ, aliasTxt) -> + Doc.concat [ + printOutTypeDoc typ; + Doc.text " as '"; + Doc.text aliasTxt + ] + | Otyp_constr (outIdent, []) -> + printOutIdentDoc ~allowUident:false outIdent + | Otyp_manifest (typ1, typ2) -> + Doc.concat [ + printOutTypeDoc typ1; + Doc.text " = "; + printOutTypeDoc typ2; + ] + | Otyp_record record -> + printRecordDeclarationDoc ~inline:true record + | Otyp_stuff txt -> Doc.text txt + | Otyp_var (ng, s) -> Doc.concat [ + Doc.text ("'" ^ (if ng then "_" else "")); + Doc.text s + ] + | Otyp_object (fields, rest) -> printObjectFields fields rest + | Otyp_class _ -> Doc.nil + | Otyp_attribute (typ, attribute) -> + Doc.group ( + Doc.concat [ + printOutAttributeDoc attribute; + Doc.line; + printOutTypeDoc typ; + ] + ) + (* example: Red | Blue | Green | CustomColour(float, float, float) *) + | Otyp_sum constructors -> + printOutConstructorsDoc constructors + + (* example: {"name": string, "age": int} *) + | Otyp_constr ( + (Oide_dot ((Oide_ident "Js"), "t")), + [Otyp_object (fields, rest)] + ) -> printObjectFields fields rest + + (* example: node *) + | Otyp_constr (outIdent, args) -> + let argsDoc = match args with + | [] -> Doc.nil + | args -> + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutTypeDoc args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + in + Doc.group ( + Doc.concat [ + printOutIdentDoc outIdent; + argsDoc; + ] + ) + | Otyp_tuple tupleArgs -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutTypeDoc tupleArgs + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + | Otyp_poly (vars, outType) -> + Doc.group ( + Doc.concat [ + Doc.join ~sep:Doc.space ( + List.map (fun var -> Doc.text ("'" ^ var)) vars + ); + printOutTypeDoc outType; + ] + ) + | Otyp_arrow _ as typ -> + let (typArgs, typ) = collectArrowArgs typ [] in + let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (lbl, typ) -> + if lbl = "" then + printOutTypeDoc typ + else + Doc.group ( + Doc.concat [ + Doc.text ("~" ^ lbl ^ ": "); + printOutTypeDoc typ + ] + ) + ) typArgs + ) in + let argsDoc = + let needsParens = match typArgs with + | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true + (* single argument should not be wrapped *) + | ["", _] -> false + | _ -> true + in + if needsParens then + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + args; + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + else args + in + Doc.concat [ + argsDoc; + Doc.text " => "; + printOutTypeDoc typ; + ] + | Otyp_module (_modName, _stringList, _outTypes) -> + Doc.nil + + and printOutVariant variant = match variant with + | Ovar_fields fields -> (* (string * bool * out_type list) list *) + Doc.join ~sep:Doc.line ( + (* + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand + *) + List.mapi (fun i (name, ampersand, types) -> + let needsParens = match types with + | [(Outcometree.Otyp_tuple _)] -> false + | _ -> true + in + Doc.concat [ + if i > 0 then + Doc.text "| " + else + Doc.ifBreaks (Doc.text "| ") Doc.nil; + Doc.group ( + Doc.concat [ + Doc.text "#"; + printIdentLike ~allowUident:true name; + match types with + | [] -> Doc.nil + | types -> + Doc.concat [ + if ampersand then Doc.text " & " else Doc.nil; + Doc.indent ( + Doc.concat [ + Doc.join ~sep:(Doc.concat [Doc.text " &"; Doc.line]) + (List.map (fun typ -> + let outTypeDoc = printOutTypeDoc typ in + if needsParens then + Doc.concat [Doc.lparen; outTypeDoc; Doc.rparen] + else + outTypeDoc + ) types) + ]; + ); + ] + ] + ) + ] + ) fields + ) + | Ovar_typ typ -> printOutTypeDoc typ + + and printObjectFields fields rest = + let dots = match rest with + | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") + | None -> Doc.nil + in + Doc.group ( + Doc.concat [ + Doc.lbrace; + dots; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (lbl, outType) -> Doc.group ( + Doc.concat [ + Doc.text ("\"" ^ lbl ^ "\": "); + printOutTypeDoc outType; + ] + )) fields + ) + ] + ); + Doc.softLine; + Doc.trailingComma; + Doc.rbrace; + ] + ) + + + and printOutConstructorsDoc constructors = + Doc.group ( + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line ( + List.mapi (fun i constructor -> + Doc.concat [ + if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil; + printOutConstructorDoc constructor; + ] + ) constructors + ) + ] + ) + ) + + and printOutConstructorDoc (name, args, gadt) = + let gadtDoc = match gadt with + | Some outType -> + Doc.concat [ + Doc.text ": "; + printOutTypeDoc outType + ] + | None -> Doc.nil + in + let argsDoc = match args with + | [] -> Doc.nil + | [Otyp_record record] -> + (* inline records + * | Root({ + * mutable value: 'value, + * mutable updatedTime: float, + * }) + *) + Doc.concat [ + Doc.lparen; + Doc.indent ( + printRecordDeclarationDoc ~inline:true record; + ); + Doc.rparen; + ] + | _types -> + Doc.indent ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutTypeDoc args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + Doc.group ( + Doc.concat [ + Doc.text name; + argsDoc; + gadtDoc + ] + ) + + and printRecordDeclRowDoc (name, mut, arg) = + Doc.group ( + Doc.concat [ + if mut then Doc.text "mutable " else Doc.nil; + printIdentLike ~allowUident:false name; + Doc.text ": "; + printOutTypeDoc arg; + ] + ) + + and printRecordDeclarationDoc ~inline rows = + let content = Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printRecordDeclRowDoc rows + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] in + if not inline then + Doc.group content + else content + + let printOutType fmt outType = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutTypeDoc outType)) + + let printTypeParameterDoc (typ, (co, cn)) = + Doc.concat [ + if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil; + if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ) + ] + + + let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) = + match outSigItem with + | Osig_class _ | Osig_class_type _ -> Doc.nil + | Osig_ellipsis -> Doc.dotdotdot + | Osig_value valueDecl -> + Doc.group ( + Doc.concat [ + printOutAttributesDoc valueDecl.oval_attributes; + Doc.text ( + match valueDecl.oval_prims with | [] -> "let " | _ -> "external " + ); + Doc.text valueDecl.oval_name; + Doc.text ":"; + Doc.space; + printOutTypeDoc valueDecl.oval_type; + match valueDecl.oval_prims with + | [] -> Doc.nil + | primitives -> Doc.indent ( + Doc.concat [ + Doc.text " ="; + Doc.line; + Doc.group ( + Doc.join ~sep:Doc.line (List.map (fun prim -> Doc.text ("\"" ^ prim ^ "\"")) primitives) + ) + ] + ) + ] + ) + | Osig_typext (outExtensionConstructor, _outExtStatus) -> + printOutExtensionConstructorDoc outExtensionConstructor + | Osig_modtype (modName, Omty_signature []) -> + Doc.concat [ + Doc.text "module type "; + Doc.text modName; + ] + | Osig_modtype (modName, outModuleType) -> + Doc.group ( + Doc.concat [ + Doc.text "module type "; + Doc.text modName; + Doc.text " = "; + printOutModuleTypeDoc outModuleType; + ] + ) + | Osig_module (modName, Omty_alias ident, _) -> + Doc.group ( + Doc.concat [ + Doc.text "module "; + Doc.text modName; + Doc.text " ="; + Doc.line; + printOutIdentDoc ident; + ] + ) + | Osig_module (modName, outModType, outRecStatus) -> + Doc.group ( + Doc.concat [ + Doc.text ( + match outRecStatus with + | Orec_not -> "module " + | Orec_first -> "module rec " + | Orec_next -> "and" + ); + Doc.text modName; + Doc.text " = "; + printOutModuleTypeDoc outModType; + ] + ) + | Osig_type (outTypeDecl, outRecStatus) -> + (* TODO: manifest ? *) + let attrs = match outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed with + | false, false -> Doc.nil + | true, false -> + Doc.concat [Doc.text "@immediate"; Doc.line] + | false, true -> + Doc.concat [Doc.text "@unboxed"; Doc.line] + | true, true -> + Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] + in + let kw = Doc.text ( + match outRecStatus with + | Orec_not -> "type " + | Orec_first -> "type rec " + | Orec_next -> "and " + ) in + let typeParams = match outTypeDecl.otype_params with + | [] -> Doc.nil + | _params -> Doc.group ( + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printTypeParameterDoc outTypeDecl.otype_params + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + ) + in + let privateDoc = match outTypeDecl.otype_private with + | Asttypes.Private -> Doc.text "private " + | Public -> Doc.nil + in + let kind = match outTypeDecl.otype_type with + | Otyp_open -> Doc.concat [ + Doc.text " = "; + privateDoc; + Doc.text ".."; + ] + | Otyp_abstract -> Doc.nil + | Otyp_record record -> Doc.concat [ + Doc.text " = "; + privateDoc; + printRecordDeclarationDoc ~inline:false record; + ] + | typ -> Doc.concat [ + Doc.text " = "; + printOutTypeDoc typ + ] + in + let constraints = match outTypeDecl.otype_cstrs with + | [] -> Doc.nil + | _ -> Doc.group ( + Doc.concat [ + Doc.line; + Doc.indent ( + Doc.concat [ + Doc.hardLine; + Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) -> + Doc.group ( + Doc.concat [ + Doc.text "constraint "; + printOutTypeDoc typ1; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printOutTypeDoc typ2; + ] + ) + ] + ) + ) outTypeDecl.otype_cstrs) + ] + ) + ] + ) in + Doc.group ( + Doc.concat [ + attrs; + Doc.group ( + Doc.concat [ + attrs; + kw; + printIdentLike ~allowUident:false outTypeDecl.otype_name; + typeParams; + kind + ] + ); + constraints + ] + ) + + and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = + match outModType with + | Omty_abstract -> Doc.nil + | Omty_ident ident -> printOutIdentDoc ident + (* example: module Increment = (M: X_int) => X_int *) + | Omty_functor _ -> + let (args, returnModType) = collectFunctorArgs outModType [] in + let argsDoc = match args with + | [_, None] -> Doc.text "()" + | args -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (lbl, optModType) -> Doc.group ( + Doc.concat [ + Doc.text lbl; + match optModType with + | None -> Doc.nil + | Some modType -> Doc.concat [ + Doc.text ": "; + printOutModuleTypeDoc modType; + ] + ] + )) args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + Doc.group ( + Doc.concat [ + argsDoc; + Doc.text " => "; + printOutModuleTypeDoc returnModType + ] + ) + | Omty_signature [] -> Doc.nil + | Omty_signature signature -> + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.line; + printOutSignatureDoc signature; + ] + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Omty_alias _ident -> Doc.nil + + and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | Outcometree.Osig_typext(ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + Outcometree.Osig_typext(ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + items + in + let te = + { Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + let doc = printOutTypeExtensionDoc te in + loop items (doc::acc) + | item::items -> + let doc = printOutSigItemDoc item in + loop items (doc::acc) + in + match loop signature [] with + | [doc] -> doc + | docs -> + Doc.breakableGroup ~forceBreak:true ( + Doc.join ~sep:Doc.line docs + ) + + and printOutExtensionConstructorDoc (outExt : Outcometree.out_extension_constructor) = + let typeParams = match outExt.oext_type_params with + | [] -> Doc.nil + | params -> + Doc.group( + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map + (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) + params + + ) + ] + ); + Doc.softLine; + Doc.greaterThan; + ] + ) + + in + Doc.group ( + Doc.concat [ + Doc.text "type "; + printIdentLike ~allowUident:false outExt.oext_type_name; + typeParams; + Doc.text " += "; + Doc.line; + if outExt.oext_private = Asttypes.Private then + Doc.text "private " + else + Doc.nil; + printOutConstructorDoc + (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type) + ] + ) + + and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = + let typeParams = match typeExtension.otyext_params with + | [] -> Doc.nil + | params -> + Doc.group( + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map + (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) + params + + ) + ] + ); + Doc.softLine; + Doc.greaterThan; + ] + ) + + in + Doc.group ( + Doc.concat [ + Doc.text "type "; + printIdentLike ~allowUident:false typeExtension.otyext_name; + typeParams; + Doc.text " += "; + if typeExtension.otyext_private = Asttypes.Private then + Doc.text "private " + else + Doc.nil; + printOutConstructorsDoc typeExtension.otyext_constructors; + ] + ) + + let printOutSigItem fmt outSigItem = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) + + let printOutSignature fmt signature = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutSignatureDoc signature)) + + let validFloatLexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." else + match (s.[i] [@doesNotRaise]) with + | '0' .. '9' | '-' -> loop (i+1) + | _ -> s + in loop 0 + + let floatRepres f = + match classify_float f with + | FP_nan -> "nan" + | FP_infinite -> + if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = (float_of_string [@doesNotRaise]) s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = (float_of_string [@doesNotRaise]) s2 then s2 else + Printf.sprintf "%.18g" f + in validFloatLexeme float_val + + let rec printOutValueDoc (outValue : Outcometree.out_value) = + match outValue with + | Oval_array outValues -> + Doc.group ( + Doc.concat [ + Doc.lbracket; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutValueDoc outValues + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ] + ) + | Oval_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") + | Oval_constr (outIdent, outValues) -> + Doc.group ( + Doc.concat [ + printOutIdentDoc outIdent; + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutValueDoc outValues + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + | Oval_ellipsis -> Doc.text "..." + | Oval_int i -> Doc.text (Format.sprintf "%i" i) + | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) + | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) + | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) + | Oval_float f -> Doc.text (floatRepres f) + | Oval_list outValues -> + Doc.group ( + Doc.concat [ + Doc.text "list["; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutValueDoc outValues + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ] + ) + | Oval_printer fn -> + let fmt = Format.str_formatter in + fn fmt; + let str = Format.flush_str_formatter () in + Doc.text str + | Oval_record rows -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (outIdent, outValue) -> Doc.group ( + Doc.concat [ + printOutIdentDoc outIdent; + Doc.text ": "; + printOutValueDoc outValue; + ] + ) + ) rows + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + | Oval_string (txt, _sizeToPrint, _kind) -> + Doc.text (escapeStringContents txt) + | Oval_stuff txt -> Doc.text txt + | Oval_tuple outValues -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map printOutValueDoc outValues + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + (* Not supported by NapkinScript *) + | Oval_variant _ -> Doc.nil + + let printOutExceptionDoc exc outValue = + match exc with + | Sys.Break -> Doc.text "Interrupted." + | Out_of_memory -> Doc.text "Out of memory during evaluation." + | Stack_overflow -> + Doc.text "Stack overflow during evaluation (looping recursion?)." + | _ -> + Doc.group ( + Doc.indent( + Doc.concat [ + Doc.text "Exception:"; + Doc.line; + printOutValueDoc outValue; + ] + ) + ) + + let printOutPhraseSignature signature = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | (Outcometree.Osig_typext(ext, Oext_first), None)::signature -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Outcometree.Osig_typext(ext, Oext_next), None)::items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type)::acc) + items + | _ -> (List.rev acc, items) + in + let exts, signature = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + signature + in + let te = + { Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private } + in + let doc = printOutTypeExtensionDoc te in + loop signature (doc::acc) + | (sigItem, optOutValue)::signature -> + let doc = match optOutValue with + | None -> + printOutSigItemDoc sigItem + | Some outValue -> + Doc.group ( + Doc.concat [ + printOutSigItemDoc sigItem; + Doc.text " = "; + printOutValueDoc outValue; + ] + ) + in + loop signature (doc::acc) + in + Doc.breakableGroup ~forceBreak:true ( + Doc.join ~sep:Doc.line (loop signature []) + ) + + let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = + match outPhrase with + | Ophr_eval (outValue, outType) -> + Doc.group ( + Doc.concat [ + Doc.text "- : "; + printOutTypeDoc outType; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printOutValueDoc outValue; + ] + ) + ] + ) + | Ophr_signature [] -> Doc.nil + | Ophr_signature signature -> printOutPhraseSignature signature + | Ophr_exception (exc, outValue) -> + printOutExceptionDoc exc outValue + + let printOutPhrase fmt outPhrase = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) + + let printOutModuleType fmt outModuleType = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) + + let printOutTypeExtension fmt typeExtension = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) + + let printOutValue fmt outValue = + Format.pp_print_string fmt + (Doc.toString ~width:80 (printOutValueDoc outValue)) + + + + + +(* Not supported in Napkin *) +(* Oprint.out_class_type *) + let setup = lazy begin + Oprint.out_value := printOutValue; + Oprint.out_type := printOutType; + Oprint.out_module_type := printOutModuleType; + Oprint.out_sig_item := printOutSigItem; + Oprint.out_signature := printOutSignature; + Oprint.out_type_extension := printOutTypeExtension; + Oprint.out_phrase := printOutPhrase + end + diff --git a/src/rescript-editor-support/vendor/res_outcome_printer/res_token.ml b/src/rescript-editor-support/vendor/res_outcome_printer/res_token.ml new file mode 100644 index 00000000..c7b77770 --- /dev/null +++ b/src/rescript-editor-support/vendor/res_outcome_printer/res_token.ml @@ -0,0 +1,223 @@ +module Comment = Res_comment +module CharacterCodes = Res_character_codes + +type t = + | Open + | True | False + | Character of char + | Int of {i: string; suffix: char option} + | Float of {f: string; suffix: char option} + | String of string + | Lident of string + | Uident of string + | As + | Dot | DotDot | DotDotDot + | Bang + | Semicolon + | Let + | And + | Rec + | Underscore + | SingleQuote + | Equal | EqualEqual | EqualEqualEqual + | Bar + | Lparen + | Rparen + | Lbracket + | Rbracket + | Lbrace + | Rbrace + | Colon + | Comma + | Eof + | Exception + | Backslash [@live] + | Forwardslash | ForwardslashDot + | Asterisk | AsteriskDot | Exponentiation + | Minus | MinusDot + | Plus | PlusDot | PlusPlus | PlusEqual + | ColonGreaterThan + | GreaterThan + | LessThan + | LessThanSlash + | Hash | HashEqual + | Assert + | Lazy + | Tilde + | Question + | If | Else | For | In | To | Downto | While | Switch + | When + | EqualGreater | MinusGreater + | External + | Typ + | Private + | Mutable + | Constraint + | Include + | Module + | Of + | With + | Land | Lor + | Band (* Bitwise and: & *) + | BangEqual | BangEqualEqual + | LessEqual | GreaterEqual + | ColonEqual + | At | AtAt + | Percent | PercentPercent + | Comment of Comment.t + | List + | TemplateTail of string + | TemplatePart of string + | Backtick + | BarGreater + | Try + | Import + | Export + +let precedence = function + | HashEqual | ColonEqual -> 1 + | Lor -> 2 + | Land -> 3 + | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan + | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4 + | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 + | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 + | Exponentiation -> 7 + | MinusGreater -> 8 + | Dot -> 9 + | _ -> 0 + +let toString = function + | Open -> "open" + | True -> "true" | False -> "false" + | Character c -> "character '" ^ (Char.escaped c) ^ "'" + | String s -> "string \"" ^ s ^ "\"" + | Lident str -> str + | Uident str -> str + | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." + | Int {i} -> "int " ^ i + | Float {f} -> "Float: " ^ f + | Bang -> "!" + | Semicolon -> ";" + | Let -> "let" + | And -> "and" + | Rec -> "rec" + | Underscore -> "_" + | SingleQuote -> "'" + | Equal -> "=" | EqualEqual -> "==" | EqualEqualEqual -> "===" + | Eof -> "eof" + | Bar -> "|" + | As -> "as" + | Lparen -> "(" | Rparen -> ")" + | Lbracket -> "[" | Rbracket -> "]" + | Lbrace -> "{" | Rbrace -> "}" + | ColonGreaterThan -> ":>" + | Colon -> ":" + | Comma -> "," + | Minus -> "-" | MinusDot -> "-." + | Plus -> "+" | PlusDot -> "+." | PlusPlus -> "++" | PlusEqual -> "+=" + | Backslash -> "\\" + | Forwardslash -> "/" | ForwardslashDot -> "/." + | Exception -> "exception" + | Hash -> "#" | HashEqual -> "#=" + | GreaterThan -> ">" + | LessThan -> "<" + | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**" + | Assert -> "assert" + | Lazy -> "lazy" + | Tilde -> "tilde" + | Question -> "?" + | If -> "if" + | Else -> "else" + | For -> "for" + | In -> "in" + | To -> "to" + | Downto -> "downto" + | While -> "while" + | Switch -> "switch" + | When -> "when" + | EqualGreater -> "=>" | MinusGreater -> "->" + | External -> "external" + | Typ -> "type" + | Private -> "private" + | Constraint -> "constraint" + | Mutable -> "mutable" + | Include -> "include" + | Module -> "module" + | Of -> "of" + | With -> "with" + | Lor -> "||" + | Band -> "&" | Land -> "&&" + | BangEqual -> "!=" | BangEqualEqual -> "!==" + | GreaterEqual -> ">=" | LessEqual -> "<=" + | ColonEqual -> ":=" + | At -> "@" | AtAt -> "@@" + | Percent -> "%" | PercentPercent -> "%%" + | Comment c -> "Comment(" ^ (Comment.toString c) ^ ")" + | List -> "list{" + | TemplatePart text -> text ^ "${" + | TemplateTail text -> "TemplateTail(" ^ text ^ ")" + | Backtick -> "`" + | BarGreater -> "|>" + | Try -> "try" + | Import -> "import" + | Export -> "export" + +let keywordTable = function +| "true" -> True +| "false" -> False +| "open" -> Open +| "let" -> Let +| "rec" -> Rec +| "and" -> And +| "as" -> As +| "exception" -> Exception +| "assert" -> Assert +| "lazy" -> Lazy +| "if" -> If +| "else" -> Else +| "for" -> For +| "in" -> In +| "to" -> To +| "downto" -> Downto +| "while" -> While +| "switch" -> Switch +| "when" -> When +| "external" -> External +| "type" -> Typ +| "private" -> Private +| "mutable" -> Mutable +| "constraint" -> Constraint +| "include" -> Include +| "module" -> Module +| "of" -> Of +| "list{" -> List +| "with" -> With +| "try" -> Try +| "import" -> Import +| "export" -> Export +| _ -> raise Not_found +[@@raises Not_found] + +let isKeyword = function + | True | False | Open | Let | Rec | And | As + | Exception | Assert | Lazy | If | Else | For | In | To + | Downto | While | Switch | When | External | Typ | Private + | Mutable | Constraint | Include | Module | Of + | Land | Lor | List | With + | Try | Import | Export -> true + | _ -> false + +let lookupKeyword str = + try keywordTable str with + | Not_found -> + if CharacterCodes.isUpperCase (int_of_char (str.[0] [@doesNotRaise])) then + Uident str + else Lident str + +let isKeywordTxt str = + try let _ = keywordTable str in true with + | Not_found -> false + +let catch = Lident "catch" From 90dccd23d54557e991f050e284a898dd8464fd13 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 1 Dec 2020 14:26:05 +0100 Subject: [PATCH 2/2] Use existing functions to convert to string. --- src/rescript-editor-support/PrintType.re | 26 ++++++++---------------- 1 file changed, 9 insertions(+), 17 deletions(-) diff --git a/src/rescript-editor-support/PrintType.re b/src/rescript-editor-support/PrintType.re index c1197754..9295088d 100644 --- a/src/rescript-editor-support/PrintType.re +++ b/src/rescript-editor-support/PrintType.re @@ -1,23 +1,15 @@ let printExpr = typ => { - try( - Res_outcome_printer.printOutType( - Format.str_formatter, - Printtyp.tree_of_typexp(false, typ), - ) - ) { - | _ => Format.fprintf(Format.str_formatter, "Unable to print type") - }; - Format.flush_str_formatter(); + Res_doc.toString( + ~width=60, + Res_outcome_printer.printOutTypeDoc(Printtyp.tree_of_typexp(false, typ)), + ); }; let printDecl = (~recStatus, name, decl) => { - try( - Res_outcome_printer.printOutSigItem( - Format.str_formatter, + Res_doc.toString( + ~width=60, + Res_outcome_printer.printOutSigItemDoc( Printtyp.tree_of_type_declaration(Ident.create(name), decl, recStatus), - ) - ) { - | _ => Format.fprintf(Format.str_formatter, "Unable to print type") - }; - Format.flush_str_formatter(); + ), + ); };