|
1 |
| - module Doc = Napkin_doc |
| 1 | +(* For the curious: the outcome printer is a printer to print data |
| 2 | + * from the outcometree.mli file in the ocaml compiler. |
| 3 | + * The outcome tree is used by: |
| 4 | + * - ocaml's toplevel/repl, print results/errors |
| 5 | + * - super errors, print nice errors |
| 6 | + * - editor tooling, e.g. show type on hover |
| 7 | + * |
| 8 | + * In general it represent messages to show results or errors to the user. *) |
| 9 | + |
| 10 | +module Doc = Napkin_doc |
| 11 | +module Token = Napkin_token |
| 12 | + |
| 13 | +type identifierStyle = |
| 14 | + | ExoticIdent |
| 15 | + | NormalIdent |
| 16 | + |
| 17 | +let classifyIdentContent ~allowUident txt = |
| 18 | + let len = String.length txt in |
| 19 | + let rec go i = |
| 20 | + if i == len then NormalIdent |
| 21 | + else |
| 22 | + let c = String.unsafe_get txt i in |
| 23 | + if i == 0 && not ( |
| 24 | + (allowUident && (c >= 'A' && c <= 'Z')) || |
| 25 | + (c >= 'a' && c <= 'z') || c = '_' || (c >= '0' && c <= '9')) then |
| 26 | + ExoticIdent |
| 27 | + else if not ( |
| 28 | + (c >= 'a' && c <= 'z') |
| 29 | + || (c >= 'A' && c <= 'Z') |
| 30 | + || c = '\'' |
| 31 | + || c = '_' |
| 32 | + || (c >= '0' && c <= '9')) |
| 33 | + then |
| 34 | + ExoticIdent |
| 35 | + else |
| 36 | + go (i + 1) |
| 37 | + in |
| 38 | + if Token.isKeywordTxt txt then |
| 39 | + ExoticIdent |
| 40 | + else |
| 41 | + go 0 |
| 42 | + |
| 43 | +let printIdentLike ~allowUident txt = |
| 44 | + match classifyIdentContent ~allowUident txt with |
| 45 | + | ExoticIdent -> Doc.concat [ |
| 46 | + Doc.text "\\\""; |
| 47 | + Doc.text txt; |
| 48 | + Doc.text"\"" |
| 49 | + ] |
| 50 | + | NormalIdent -> Doc.text txt |
| 51 | + |
2 | 52 | (* Napkin doesn't have parenthesized identifiers.
|
3 | 53 | * We don't support custom operators. *)
|
4 | 54 | let parenthesized_ident _name = true
|
|
45 | 95 | print_ident fmt id2;
|
46 | 96 | Format.pp_print_char fmt ')' *)
|
47 | 97 |
|
48 |
| - let rec printOutIdentDoc (ident : Outcometree.out_ident) = |
| 98 | + let rec printOutIdentDoc ?(allowUident=true) (ident : Outcometree.out_ident) = |
49 | 99 | match ident with
|
50 |
| - | Oide_ident s -> Doc.text s |
| 100 | + | Oide_ident s -> printIdentLike ~allowUident s |
51 | 101 | | Oide_dot (ident, s) -> Doc.concat [
|
52 | 102 | printOutIdentDoc ident;
|
53 | 103 | Doc.dot;
|
|
95 | 145 |
|
96 | 146 | let rec printOutTypeDoc (outType: Outcometree.out_type) =
|
97 | 147 | match outType with
|
98 |
| - | Otyp_abstract | Otyp_variant _ (* don't support poly-variants atm *) | Otyp_open -> Doc.nil |
| 148 | + | Otyp_abstract | Otyp_open -> Doc.nil |
| 149 | + | Otyp_variant (nonGen, outVariant, closed, labels) -> |
| 150 | + (* bool * out_variant * bool * (string list) option *) |
| 151 | + let opening = match (closed, labels) with |
| 152 | + | (true, None) -> (* [#A | #B] *) Doc.softLine |
| 153 | + | (false, None) -> |
| 154 | + (* [> #A | #B] *) |
| 155 | + Doc.concat [Doc.greaterThan; Doc.line] |
| 156 | + | (true, Some []) -> |
| 157 | + (* [< #A | #B] *) |
| 158 | + Doc.concat [Doc.lessThan; Doc.line] |
| 159 | + | (true, Some _) -> |
| 160 | + (* [< #A | #B > #X #Y ] *) |
| 161 | + Doc.concat [Doc.lessThan; Doc.line] |
| 162 | + | (false, Some _) -> |
| 163 | + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) |
| 164 | + Doc.concat [Doc.text "?"; Doc.line] |
| 165 | + in |
| 166 | + Doc.group ( |
| 167 | + Doc.concat [ |
| 168 | + if nonGen then Doc.text "_" else Doc.nil; |
| 169 | + Doc.lbracket; |
| 170 | + Doc.indent ( |
| 171 | + Doc.concat [ |
| 172 | + opening; |
| 173 | + printOutVariant outVariant |
| 174 | + ] |
| 175 | + ); |
| 176 | + begin match labels with |
| 177 | + | None | Some [] -> Doc.nil |
| 178 | + | Some tags -> |
| 179 | + Doc.group ( |
| 180 | + Doc.concat [ |
| 181 | + Doc.space; |
| 182 | + Doc.join ~sep:Doc.space ( |
| 183 | + List.map (fun lbl -> printIdentLike ~allowUident:true lbl) tags |
| 184 | + ) |
| 185 | + ] |
| 186 | + ) |
| 187 | + end; |
| 188 | + Doc.softLine; |
| 189 | + Doc.rbracket; |
| 190 | + ] |
| 191 | + ) |
99 | 192 | | Otyp_alias (typ, aliasTxt) ->
|
100 | 193 | Doc.concat [
|
101 | 194 | printOutTypeDoc typ;
|
102 | 195 | Doc.text " as '";
|
103 | 196 | Doc.text aliasTxt
|
104 | 197 | ]
|
105 | 198 | | Otyp_constr (outIdent, []) ->
|
106 |
| - printOutIdentDoc outIdent |
| 199 | + printOutIdentDoc ~allowUident:false outIdent |
107 | 200 | | Otyp_manifest (typ1, typ2) ->
|
108 | 201 | Doc.concat [
|
109 | 202 | printOutTypeDoc typ1;
|
|
236 | 329 | | Otyp_module (_modName, _stringList, _outTypes) ->
|
237 | 330 | Doc.nil
|
238 | 331 |
|
| 332 | + and printOutVariant variant = match variant with |
| 333 | + | Ovar_fields fields -> (* (string * bool * out_type list) list *) |
| 334 | + Doc.join ~sep:Doc.line ( |
| 335 | + (* |
| 336 | + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand |
| 337 | + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand |
| 338 | + *) |
| 339 | + List.mapi (fun i (name, ampersand, types) -> |
| 340 | + let needsParens = match types with |
| 341 | + | [(Outcometree.Otyp_tuple _)] -> false |
| 342 | + | _ -> true |
| 343 | + in |
| 344 | + Doc.concat [ |
| 345 | + if i > 0 then |
| 346 | + Doc.text "| " |
| 347 | + else |
| 348 | + Doc.ifBreaks (Doc.text "| ") Doc.nil; |
| 349 | + Doc.group ( |
| 350 | + Doc.concat [ |
| 351 | + Doc.text "#"; |
| 352 | + printIdentLike ~allowUident:true name; |
| 353 | + match types with |
| 354 | + | [] -> Doc.nil |
| 355 | + | types -> |
| 356 | + Doc.concat [ |
| 357 | + if ampersand then Doc.text " & " else Doc.nil; |
| 358 | + Doc.indent ( |
| 359 | + Doc.concat [ |
| 360 | + Doc.join ~sep:(Doc.concat [Doc.text " &"; Doc.line]) |
| 361 | + (List.map (fun typ -> |
| 362 | + let outTypeDoc = printOutTypeDoc typ in |
| 363 | + if needsParens then |
| 364 | + Doc.concat [Doc.lparen; outTypeDoc; Doc.rparen] |
| 365 | + else |
| 366 | + outTypeDoc |
| 367 | + ) types) |
| 368 | + ]; |
| 369 | + ); |
| 370 | + ] |
| 371 | + ] |
| 372 | + ) |
| 373 | + ] |
| 374 | + ) fields |
| 375 | + ) |
| 376 | + | Ovar_typ typ -> printOutTypeDoc typ |
| 377 | + |
239 | 378 | and printObjectFields fields rest =
|
240 | 379 | let dots = match rest with
|
241 | 380 | | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..")
|
|
337 | 476 | Doc.group (
|
338 | 477 | Doc.concat [
|
339 | 478 | if mut then Doc.text "mutable " else Doc.nil;
|
340 |
| - Doc.text name; |
| 479 | + printIdentLike ~allowUident:false name; |
341 | 480 | Doc.text ": ";
|
342 | 481 | printOutTypeDoc arg;
|
343 | 482 | ]
|
|
532 | 671 | Doc.concat [
|
533 | 672 | attrs;
|
534 | 673 | kw;
|
535 |
| - Doc.text outTypeDecl.otype_name; |
| 674 | + printIdentLike ~allowUident:false outTypeDecl.otype_name; |
536 | 675 | typeParams;
|
537 | 676 | kind
|
538 | 677 | ]
|
|
666 | 805 | Doc.group (
|
667 | 806 | Doc.concat [
|
668 | 807 | Doc.text "type ";
|
669 |
| - Doc.text outExt.oext_type_name; |
| 808 | + printIdentLike ~allowUident:false outExt.oext_type_name; |
670 | 809 | typeParams;
|
671 | 810 | Doc.text " += ";
|
672 | 811 | Doc.line;
|
|
705 | 844 | Doc.group (
|
706 | 845 | Doc.concat [
|
707 | 846 | Doc.text "type ";
|
708 |
| - Doc.text typeExtension.otyext_name; |
| 847 | + printIdentLike ~allowUident:false typeExtension.otyext_name; |
709 | 848 | typeParams;
|
710 | 849 | Doc.text " += ";
|
711 | 850 | if typeExtension.otyext_private = Asttypes.Private then
|
|
0 commit comments