diff options
| -rw-r--r-- | parsing/parser.mly | 3 | ||||
| -rw-r--r-- | typing/btype.ml | 9 | ||||
| -rw-r--r-- | typing/btype.mli | 1 | ||||
| -rw-r--r-- | typing/oprint.ml | 19 | ||||
| -rw-r--r-- | typing/printtyp.ml | 18 | ||||
| -rw-r--r-- | typing/typetexp.ml | 24 |
6 files changed, 67 insertions, 7 deletions
diff --git a/parsing/parser.mly b/parsing/parser.mly index c6b3c4de6..f723e5aeb 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -2008,10 +2008,11 @@ label_longident: type_longident: type_ident { Lident $1 } | mod_ext_longident DOT type_ident { Ldot($1, $3) } + | BANG constr_longident { $2 } ; type_ident: LIDENT { $1 } - | LIDENT DOT UIDENT { $1 ^ "." ^ $3 } +/* | LIDENT DOT UIDENT { $1 ^ "." ^ $3 } */ ; mod_longident: UIDENT { Lident $1 } diff --git a/typing/btype.ml b/typing/btype.ml index 3e49db047..6a0359e48 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -689,4 +689,11 @@ let backtrack (changes, old) = let inlined_record_name typ cstr = - typ ^ "." ^ cstr + Printf.sprintf "!%s.%s" typ cstr + +let uninlined_record_name s = + if s.[0] = '!' then + let i = String.index s '.' in + Some (String.sub s 1 (i - 1), String.sub s (i + 1) (String.length s - i - 1)) + else + None diff --git a/typing/btype.mli b/typing/btype.mli index 9e4d446c1..ce886bfa0 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -212,3 +212,4 @@ val map_type_expr_cstr_args: (type_expr -> type_expr) -> val inlined_record_name: string -> string -> string +val uninlined_record_name: string -> (string * string) option diff --git a/typing/oprint.ml b/typing/oprint.ml index 3c2d63708..50908b49b 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -27,6 +27,23 @@ let rec print_ident ppf = | Oide_apply (id1, id2) -> fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + +let print_type_ident ppf = function + | Oide_ident s -> + begin match Btype.uninlined_record_name s with + | None -> pp_print_string ppf s + | Some (_typ, cstr) -> + fprintf ppf "!%s" cstr + end + | Oide_dot (m, s) as id -> + begin match Btype.uninlined_record_name s with + | None -> print_ident ppf id + | Some (_typ, cstr) -> + fprintf ppf "!%a.%s" print_ident m cstr + end + | Oide_apply _ as id -> + print_ident ppf id + let parenthesized_ident name = (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) || @@ -192,7 +209,7 @@ and print_simple_out_type ppf = | Otyp_constr (id, tyl) -> pp_open_box ppf 0; print_typargs ppf tyl; - print_ident ppf id; + print_type_ident ppf id; pp_close_box ppf () | Otyp_object (fields, rest) -> fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields diff --git a/typing/printtyp.ml b/typing/printtyp.ml index c21c2d63c..b19d6ba35 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -69,12 +69,22 @@ let rec path ppf = function | Papply(p1, p2) -> fprintf ppf "%a(%a)" path p1 path p2 +(* Note: this logic is duplicated in Oprint.print_type_ident *) let rec string_of_out_ident = function - | Oide_ident s -> s - | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s] + | Oide_ident s -> + begin match Btype.uninlined_record_name s with + | None -> s + | Some (_typ, cstr) -> Printf.sprintf "!%s" cstr + end + | Oide_dot (m, s) -> + begin match Btype.uninlined_record_name s with + | None -> Printf.sprintf "%s.%s" (string_of_out_ident m) s + | Some (_typ, cstr) -> + Printf.sprintf "!%s.%s" (string_of_out_ident m) cstr + end | Oide_apply (id1, id2) -> - String.concat "" - [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] + Printf.sprintf "%s(%s)" (string_of_out_ident id1) + (string_of_out_ident id2) let string_of_path p = string_of_out_ident (tree_of_path p) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 523d435bc..739c18c1f 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -224,6 +224,30 @@ let find_type env loc lid = let find_constructor = find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) + +let find_type env loc lid = + let s = Longident.last lid in + match s.[0] with + | 'A'..'Z' -> + let cstr = find_constructor env loc lid in + if not cstr.cstr_inlined then + failwith (Printf.sprintf + "Constructor %s does not have an inline record argument" + s + ); + begin match cstr.cstr_args with + | [{desc=Tconstr(path, _, _)}] -> + let decl = + try Env.find_type path env + with Not_found -> + assert false + in + (path, decl) + | _ -> assert false + end + | _ -> + find_type env loc lid + let find_all_constructors = find_component Env.lookup_all_constructors (fun lid -> Unbound_constructor lid) |