l4/pkg/ocaml/ocaml/contrib/typing/printtyp.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (* Xavier Leroy and Jerome Vouillon, projet Cristal, INRIA Rocquencourt*)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: printtyp.ml 8922 2008-07-19 02:13:09Z garrigue $ *)
  14
  15 (* Printing functions *)
  16
  17 open Misc
  18 open Ctype
  19 open Format
  20 open Longident
  21 open Path
  22 open Asttypes
  23 open Types
  24 open Btype
  25 open Outcometree
  26
  27 (* Print a long identifier *)
  28
  29 let rec longident ppf = function
  30   | Lident s -> fprintf ppf "%s" s
  31   | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
  32   | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
  33
  34 (* Print an identifier *)
  35
  36 let ident ppf id = fprintf ppf "%s" (Ident.name id)
  37
  38 (* Print a path *)
  39
  40 let ident_pervasive = Ident.create_persistent "Pervasives"
  41
  42 let rec tree_of_path = function
  43   | Pident id ->
  44       Oide_ident (Ident.name id)
  45   | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
  46       Oide_ident s
  47   | Pdot(p, s, pos) ->
  48       Oide_dot (tree_of_path p, s)
  49   | Papply(p1, p2) ->
  50       Oide_apply (tree_of_path p1, tree_of_path p2)
  51
  52 let rec path ppf = function
  53   | Pident id ->
  54       ident ppf id
  55   | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
  56       fprintf ppf "%s" s
  57   | Pdot(p, s, pos) ->
  58       fprintf ppf "%a.%s" path p s
  59   | Papply(p1, p2) ->
  60       fprintf ppf "%a(%a)" path p1 path p2
  61
  62 (* Print a recursive annotation *)
  63
  64 let tree_of_rec = function
  65   | Trec_not -> Orec_not
  66   | Trec_first -> Orec_first
  67   | Trec_next -> Orec_next
  68
  69 (* Print a raw type expression, with sharing *)
  70
  71 let raw_list pr ppf = function
  72     [] -> fprintf ppf "[]"
  73   | a :: l ->
  74       fprintf ppf "@[<1>[%a%t]@]" pr a
  75         (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l)
  76
  77 let rec safe_kind_repr v = function
  78     Fvar {contents=Some k}  ->
  79       if List.memq k v then "Fvar loop" else
  80       safe_kind_repr (k::v) k
  81   | Fvar _ -> "Fvar None"
  82   | Fpresent -> "Fpresent"
  83   | Fabsent -> "Fabsent"
  84
  85 let rec safe_commu_repr v = function
  86     Cok -> "Cok"
  87   | Cunknown -> "Cunknown"
  88   | Clink r ->
  89       if List.memq r v then "Clink loop" else
  90       safe_commu_repr (r::v) !r
  91
  92 let rec safe_repr v = function
  93     {desc = Tlink t} when not (List.memq t v) ->
  94       safe_repr (t::v) t
  95   | t -> t
  96
  97 let rec list_of_memo = function
  98     Mnil -> []
  99   | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem
 100   | Mlink rem -> list_of_memo !rem
 101
 102 let visited = ref []
 103 let rec raw_type ppf ty =
 104   let ty = safe_repr [] ty in
 105   if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin
 106     visited := ty :: !visited;
 107     fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level
 108       raw_type_desc ty.desc
 109   end
 110 and raw_type_list tl = raw_list raw_type tl
 111 and raw_type_desc ppf = function
 112     Tvar -> fprintf ppf "Tvar"
 113   | Tarrow(l,t1,t2,c) ->
 114       fprintf ppf "@[<hov1>Tarrow(%s,@,%a,@,%a,@,%s)@]"
 115         l raw_type t1 raw_type t2
 116         (safe_commu_repr [] c)
 117   | Ttuple tl ->
 118       fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl
 119   | Tconstr (p, tl, abbrev) ->
 120       fprintf ppf "@[<hov1>Tconstr(@,%a,@,%a,@,%a)@]" path p
 121         raw_type_list tl
 122         (raw_list path) (list_of_memo !abbrev)
 123   | Tobject (t, nm) ->
 124       fprintf ppf "@[<hov1>Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t
 125         (fun ppf ->
 126           match !nm with None -> fprintf ppf " None"
 127           | Some(p,tl) ->
 128               fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl)
 129   | Tfield (f, k, t1, t2) ->
 130       fprintf ppf "@[<hov1>Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f
 131         (safe_kind_repr [] k)
 132         raw_type t1 raw_type t2
 133   | Tnil -> fprintf ppf "Tnil"
 134   | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t
 135   | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t
 136   | Tunivar -> fprintf ppf "Tunivar"
 137   | Tpoly (t, tl) ->
 138       fprintf ppf "@[<hov1>Tpoly(@,%a,@,%a)@]"
 139         raw_type t
 140         raw_type_list tl
 141   | Tvariant row ->
 142       fprintf ppf
 143         "@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%b;@ %s%b;@ @[<1>%s%t@]}@]"
 144         "row_fields="
 145         (raw_list (fun ppf (l, f) ->
 146           fprintf ppf "@[%s,@ %a@]" l raw_field f))
 147         row.row_fields
 148         "row_more=" raw_type row.row_more
 149         "row_closed=" row.row_closed
 150         "row_fixed=" row.row_fixed
 151         "row_name="
 152         (fun ppf ->
 153           match row.row_name with None -> fprintf ppf "None"
 154           | Some(p,tl) ->
 155               fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl)
 156
 157 and raw_field ppf = function
 158     Rpresent None -> fprintf ppf "Rpresent None"
 159   | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t
 160   | Reither (c,tl,m,e) ->
 161       fprintf ppf "@[<hov1>Reither(%b,@,%a,@,%b,@,@[<1>ref%t@])@]" c
 162         raw_type_list tl m
 163         (fun ppf ->
 164           match !e with None -> fprintf ppf " None"
 165           | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)
 166   | Rabsent -> fprintf ppf "Rabsent"
 167
 168 let raw_type_expr ppf t =
 169   visited := [];
 170   raw_type ppf t;
 171   visited := []
 172
 173 (* Print a type expression *)
 174
 175 let names = ref ([] : (type_expr * string) list)
 176 let name_counter = ref 0
 177
 178 let reset_names () = names := []; name_counter := 0
 179
 180 let new_name () =
 181   let name =
 182     if !name_counter < 26
 183     then String.make 1 (Char.chr(97 + !name_counter))
 184     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
 185            string_of_int(!name_counter / 26) in
 186   incr name_counter;
 187   name
 188
 189 let name_of_type t =
 190   try List.assq t !names with Not_found ->
 191     let name = new_name () in
 192     names := (t, name) :: !names;
 193     name
 194
 195 let check_name_of_type t = ignore(name_of_type t)
 196
 197 let non_gen_mark sch ty =
 198   if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else ""
 199
 200 let print_name_of_type sch ppf t =
 201   fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t)
 202
 203 let visited_objects = ref ([] : type_expr list)
 204 let aliased = ref ([] : type_expr list)
 205 let delayed = ref ([] : type_expr list)
 206
 207 let add_delayed t =
 208   if not (List.memq t !delayed) then delayed := t :: !delayed
 209
 210 let is_aliased ty = List.memq (proxy ty) !aliased
 211 let add_alias ty =
 212   let px = proxy ty in
 213   if not (is_aliased px) then aliased := px :: !aliased
 214 let aliasable ty =
 215   match ty.desc with Tvar | Tunivar | Tpoly _ -> false | _ -> true
 216
 217 let namable_row row =
 218   row.row_name <> None &&
 219   List.for_all
 220     (fun (_, f) ->
 221        match row_field_repr f with
 222        | Reither(c, l, _, _) ->
 223            row.row_closed && if c then l = [] else List.length l = 1
 224        | _ -> true)
 225     row.row_fields
 226
 227 let rec mark_loops_rec visited ty =
 228   let ty = repr ty in
 229   let px = proxy ty in
 230   if List.memq px visited && aliasable ty then add_alias px else
 231     let visited = px :: visited in
 232     match ty.desc with
 233     | Tvar -> ()
 234     | Tarrow(_, ty1, ty2, _) ->
 235         mark_loops_rec visited ty1; mark_loops_rec visited ty2
 236     | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
 237     | Tconstr(_, tyl, _) ->
 238         List.iter (mark_loops_rec visited) tyl
 239     | Tvariant row ->
 240         if List.memq px !visited_objects then add_alias px else
 241          begin
 242           let row = row_repr row in
 243           if not (static_row row) then
 244             visited_objects := px :: !visited_objects;
 245           match row.row_name with
 246           | Some(p, tyl) when namable_row row ->
 247               List.iter (mark_loops_rec visited) tyl
 248           | _ ->
 249               iter_row (mark_loops_rec visited) row
 250          end
 251     | Tobject (fi, nm) ->
 252         if List.memq px !visited_objects then add_alias px else
 253          begin
 254           if opened_object ty then
 255             visited_objects := px :: !visited_objects;
 256           begin match !nm with
 257           | None ->
 258               let fields, _ = flatten_fields fi in
 259               List.iter
 260                 (fun (_, kind, ty) ->
 261                   if field_kind_repr kind = Fpresent then
 262                     mark_loops_rec visited ty)
 263                 fields
 264           | Some (_, l) ->
 265               List.iter (mark_loops_rec visited) (List.tl l)
 266           end
 267         end
 268     | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
 269         mark_loops_rec visited ty1; mark_loops_rec visited ty2
 270     | Tfield(_, _, _, ty2) ->
 271         mark_loops_rec visited ty2
 272     | Tnil -> ()
 273     | Tsubst ty -> mark_loops_rec visited ty
 274     | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
 275     | Tpoly (ty, tyl) ->
 276         List.iter (fun t -> add_alias t) tyl;
 277         mark_loops_rec visited ty
 278     | Tunivar -> ()
 279
 280 let mark_loops ty =
 281   normalize_type Env.empty ty;
 282   mark_loops_rec [] ty;;
 283
 284 let reset_loop_marks () =
 285   visited_objects := []; aliased := []; delayed := []
 286
 287 let reset () =
 288   reset_names (); reset_loop_marks ()
 289
 290 let reset_and_mark_loops ty =
 291   reset (); mark_loops ty
 292
 293 let reset_and_mark_loops_list tyl =
 294   reset (); List.iter mark_loops tyl
 295
 296 (* Disabled in classic mode when printing an unification error *)
 297 let print_labels = ref true
 298 let print_label ppf l =
 299   if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l
 300
 301 let rec tree_of_typexp sch ty =
 302   let ty = repr ty in
 303   let px = proxy ty in
 304   if List.mem_assq px !names && not (List.memq px !delayed) then
 305    let mark = is_non_gen sch ty in
 306    Otyp_var (mark, name_of_type px) else
 307
 308   let pr_typ () =
 309     match ty.desc with
 310     | Tvar ->
 311         Otyp_var (is_non_gen sch ty, name_of_type ty)
 312     | Tarrow(l, ty1, ty2, _) ->
 313         let pr_arrow l ty1 ty2 =
 314           let lab =
 315             if !print_labels && l <> "" || is_optional l then l else ""
 316           in
 317           let t1 =
 318             if is_optional l then
 319               match (repr ty1).desc with
 320               | Tconstr(path, [ty], _)
 321                 when Path.same path Predef.path_option ->
 322                   tree_of_typexp sch ty
 323               | _ -> Otyp_stuff "<hidden>"
 324             else tree_of_typexp sch ty1 in
 325           Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in
 326         pr_arrow l ty1 ty2
 327     | Ttuple tyl ->
 328         Otyp_tuple (tree_of_typlist sch tyl)
 329     | Tconstr(p, tyl, abbrev) ->
 330         Otyp_constr (tree_of_path p, tree_of_typlist sch tyl)
 331     | Tvariant row ->
 332         let row = row_repr row in
 333         let fields =
 334           if row.row_closed then
 335             List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
 336               row.row_fields
 337           else row.row_fields in
 338         let present =
 339           List.filter
 340             (fun (_, f) ->
 341                match row_field_repr f with
 342                | Rpresent _ -> true
 343                | _ -> false)
 344             fields in
 345         let all_present = List.length present = List.length fields in
 346         begin match row.row_name with
 347         | Some(p, tyl) when namable_row row ->
 348             let id = tree_of_path p in
 349             let args = tree_of_typlist sch tyl in
 350             if row.row_closed && all_present then
 351               Otyp_constr (id, args)
 352             else
 353               let non_gen = is_non_gen sch px in
 354               let tags =
 355                 if all_present then None else Some (List.map fst present) in
 356               Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
 357                             row.row_closed, tags)
 358         | _ ->
 359             let non_gen =
 360               not (row.row_closed && all_present) && is_non_gen sch px in
 361             let fields = List.map (tree_of_row_field sch) fields in
 362             let tags =
 363               if all_present then None else Some (List.map fst present) in
 364             Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
 365         end
 366     | Tobject (fi, nm) ->
 367         tree_of_typobject sch fi nm
 368     | Tsubst ty ->
 369         tree_of_typexp sch ty
 370     | Tlink _ | Tnil | Tfield _ ->
 371         fatal_error "Printtyp.tree_of_typexp"
 372     | Tpoly (ty, []) ->
 373         tree_of_typexp sch ty
 374     | Tpoly (ty, tyl) ->
 375         let tyl = List.map repr tyl in
 376         (* let tyl = List.filter is_aliased tyl in *)
 377         if tyl = [] then tree_of_typexp sch ty else begin
 378           let old_delayed = !delayed in
 379           List.iter add_delayed tyl;
 380           let tl = List.map name_of_type tyl in
 381           let tr = Otyp_poly (tl, tree_of_typexp sch ty) in
 382           delayed := old_delayed; tr
 383         end
 384     | Tunivar ->
 385         Otyp_var (false, name_of_type ty)
 386   in
 387   if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
 388   if is_aliased px && aliasable ty then begin
 389     check_name_of_type px;
 390     Otyp_alias (pr_typ (), name_of_type px) end
 391   else pr_typ ()
 392
 393 and tree_of_row_field sch (l, f) =
 394   match row_field_repr f with
 395   | Rpresent None | Reither(true, [], _, _) -> (l, false, [])
 396   | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty])
 397   | Reither(c, tyl, _, _) ->
 398       if c (* contradiction: un constructeur constant qui a un argument *)
 399       then (l, true, tree_of_typlist sch tyl)
 400       else (l, false, tree_of_typlist sch tyl)
 401   | Rabsent -> (l, false, [] (* une erreur, en fait *))
 402
 403 and tree_of_typlist sch tyl =
 404   List.map (tree_of_typexp sch) tyl
 405
 406 and tree_of_typobject sch fi nm =
 407   begin match !nm with
 408   | None ->
 409       let pr_fields fi =
 410         let (fields, rest) = flatten_fields fi in
 411         let present_fields =
 412           List.fold_right
 413             (fun (n, k, t) l ->
 414                match field_kind_repr k with
 415                | Fpresent -> (n, t) :: l
 416                | _ -> l)
 417             fields [] in
 418         let sorted_fields =
 419           Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
 420         tree_of_typfields sch rest sorted_fields in
 421       let (fields, rest) = pr_fields fi in
 422       Otyp_object (fields, rest)
 423   | Some (p, ty :: tyl) ->
 424       let non_gen = is_non_gen sch (repr ty) in
 425       let args = tree_of_typlist sch tyl in
 426       Otyp_class (non_gen, tree_of_path p, args)
 427   | _ ->
 428       fatal_error "Printtyp.tree_of_typobject"
 429   end
 430
 431 and is_non_gen sch ty =
 432     sch && ty.desc = Tvar && ty.level <> generic_level
 433
 434 and tree_of_typfields sch rest = function
 435   | [] ->
 436       let rest =
 437         match rest.desc with
 438         | Tvar | Tunivar -> Some (is_non_gen sch rest)
 439         | Tconstr _ -> Some false
 440         | Tnil -> None
 441         | _ -> fatal_error "typfields (1)"
 442       in
 443       ([], rest)
 444   | (s, t) :: l ->
 445       let field = (s, tree_of_typexp sch t) in
 446       let (fields, rest) = tree_of_typfields sch rest l in
 447       (field :: fields, rest)
 448
 449 let typexp sch prio ppf ty =
 450   !Oprint.out_type ppf (tree_of_typexp sch ty)
 451
 452 let type_expr ppf ty = typexp false 0 ppf ty
 453
 454 and type_sch ppf ty = typexp true 0 ppf ty
 455
 456 and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
 457
 458 (* Maxence *)
 459 let type_scheme_max ?(b_reset_names=true) ppf ty =
 460   if b_reset_names then reset_names () ;
 461   typexp true 0 ppf ty
 462 (* Fin Maxence *)
 463
 464 let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty
 465
 466 (* Print one type declaration *)
 467
 468 let tree_of_constraints params =
 469   List.fold_right
 470     (fun ty list ->
 471        let ty' = unalias ty in
 472        if proxy ty != proxy ty' then
 473          let tr = tree_of_typexp true ty in
 474          (tr, tree_of_typexp true ty') :: list
 475        else list)
 476     params []
 477
 478 let filter_params tyl =
 479   let params =
 480     List.fold_left
 481       (fun tyl ty ->
 482         let ty = repr ty in
 483         if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl
 484         else ty :: tyl)
 485       [] tyl
 486   in List.rev params
 487
 488 let string_of_mutable = function
 489   | Immutable -> ""
 490   | Mutable -> "mutable "
 491
 492 let rec tree_of_type_decl id decl =
 493
 494   reset();
 495
 496   let params = filter_params decl.type_params in
 497
 498   List.iter add_alias params;
 499   List.iter mark_loops params;
 500   List.iter check_name_of_type (List.map proxy params);
 501   let ty_manifest =
 502     match decl.type_manifest with
 503     | None -> None
 504     | Some ty ->
 505         let ty =
 506           (* Special hack to hide variant name *)
 507           match repr ty with {desc=Tvariant row} ->
 508             let row = row_repr row in
 509             begin match row.row_name with
 510               Some (Pident id', _) when Ident.same id id' ->
 511                 newgenty (Tvariant {row with row_name = None})
 512             | _ -> ty
 513             end
 514           | _ -> ty
 515         in
 516         mark_loops ty;
 517         Some ty
 518   in
 519   begin match decl.type_kind with
 520   | Type_abstract -> ()
 521   | Type_variant [] -> ()
 522   | Type_variant cstrs ->
 523       List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
 524   | Type_record(l, rep) ->
 525       List.iter (fun (_, _, ty) -> mark_loops ty) l
 526   end;
 527
 528   let type_param =
 529     function
 530     | Otyp_var (_, id) -> id
 531     | _ -> "?"
 532   in
 533   let type_defined decl =
 534     let abstr =
 535       match decl.type_kind with
 536         Type_abstract ->
 537           begin match decl.type_manifest with
 538             None -> true
 539           | Some ty -> has_constr_row ty
 540           end
 541       | Type_variant _ | Type_record(_,_) ->
 542           decl.type_private = Private
 543     in
 544     let vari =
 545       List.map2
 546         (fun ty (co,cn,ct) ->
 547           if abstr || (repr ty).desc <> Tvar then (co,cn) else (true,true))
 548         decl.type_params decl.type_variance
 549     in
 550     (Ident.name id,
 551      List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn)
 552        params vari)
 553   in
 554   let tree_of_manifest ty1 =
 555     match ty_manifest with
 556     | None -> ty1
 557     | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1)
 558   in
 559   let (name, args) = type_defined decl in
 560   let constraints = tree_of_constraints params in
 561   let ty, priv =
 562     match decl.type_kind with
 563     | Type_abstract ->
 564         begin match ty_manifest with
 565         | None -> (Otyp_abstract, Public)
 566         | Some ty ->
 567             tree_of_typexp false ty, decl.type_private
 568         end
 569     | Type_variant cstrs ->
 570         tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
 571         decl.type_private
 572     | Type_record(lbls, rep) ->
 573         tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
 574         decl.type_private
 575   in
 576   (name, args, ty, priv, constraints)
 577
 578 and tree_of_constructor (name, args) =
 579   (name, tree_of_typlist false args)
 580
 581 and tree_of_label (name, mut, arg) =
 582   (name, mut = Mutable, tree_of_typexp false arg)
 583
 584 let tree_of_type_declaration id decl rs =
 585   Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
 586
 587 let type_declaration id ppf decl =
 588   !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
 589
 590 (* Print an exception declaration *)
 591
 592 let tree_of_exception_declaration id decl =
 593   reset_and_mark_loops_list decl;
 594   let tyl = tree_of_typlist false decl in
 595   Osig_exception (Ident.name id, tyl)
 596
 597 let exception_declaration id ppf decl =
 598   !Oprint.out_sig_item ppf (tree_of_exception_declaration id decl)
 599
 600 (* Print a value declaration *)
 601
 602 let tree_of_value_description id decl =
 603   let id = Ident.name id in
 604   let ty = tree_of_type_scheme decl.val_type in
 605   let prims =
 606     match decl.val_kind with
 607     | Val_prim p -> Primitive.description_list p
 608     | _ -> []
 609   in
 610   Osig_value (id, ty, prims)
 611
 612 let value_description id ppf decl =
 613   !Oprint.out_sig_item ppf (tree_of_value_description id decl)
 614
 615 (* Print a class type *)
 616
 617 let class_var sch ppf l (m, t) =
 618   fprintf ppf
 619     "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
 620
 621 let method_type (_, kind, ty) =
 622   match field_kind_repr kind, repr ty with
 623     Fpresent, {desc=Tpoly(ty, _)} -> ty
 624   | _       , ty                  -> ty
 625
 626 let tree_of_metho sch concrete csil (lab, kind, ty) =
 627   if lab <> dummy_method then begin
 628     let kind = field_kind_repr kind in
 629     let priv = kind <> Fpresent in
 630     let virt = not (Concr.mem lab concrete) in
 631     let ty = method_type (lab, kind, ty) in
 632     Ocsg_method (lab, priv, virt, tree_of_typexp sch ty) :: csil
 633   end
 634   else csil
 635
 636 let rec prepare_class_type params = function
 637   | Tcty_constr (p, tyl, cty) ->
 638       let sty = Ctype.self_type cty in
 639       if List.memq (proxy sty) !visited_objects
 640       || List.exists (fun ty -> (repr ty).desc <> Tvar) params
 641       || List.exists (deep_occur sty) tyl
 642       then prepare_class_type params cty
 643       else List.iter mark_loops tyl
 644   | Tcty_signature sign ->
 645       let sty = repr sign.cty_self in
 646       (* Self may have a name *)
 647       let px = proxy sty in
 648       if List.memq px !visited_objects then add_alias sty
 649       else visited_objects := px :: !visited_objects;
 650       let (fields, _) =
 651         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
 652       in
 653       List.iter (fun met -> mark_loops (method_type met)) fields;
 654       Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars
 655   | Tcty_fun (_, ty, cty) ->
 656       mark_loops ty;
 657       prepare_class_type params cty
 658
 659 let rec tree_of_class_type sch params =
 660   function
 661   | Tcty_constr (p', tyl, cty) ->
 662       let sty = Ctype.self_type cty in
 663       if List.memq (proxy sty) !visited_objects
 664       || List.exists (fun ty -> (repr ty).desc <> Tvar) params
 665       then
 666         tree_of_class_type sch params cty
 667       else
 668         Octy_constr (tree_of_path p', tree_of_typlist true tyl)
 669   | Tcty_signature sign ->
 670       let sty = repr sign.cty_self in
 671       let self_ty =
 672         if is_aliased sty then
 673           Some (Otyp_var (false, name_of_type (proxy sty)))
 674         else None
 675       in
 676       let (fields, _) =
 677         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
 678       in
 679       let csil = [] in
 680       let csil =
 681         List.fold_left
 682           (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil)
 683           csil (tree_of_constraints params)
 684       in
 685       let all_vars =
 686         Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars []
 687       in
 688       (* Consequence of PR#3607: order of Map.fold has changed! *)
 689       let all_vars = List.rev all_vars in
 690       let csil =
 691         List.fold_left
 692           (fun csil (l, m, v, t) ->
 693             Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t)
 694             :: csil)
 695           csil all_vars
 696       in
 697       let csil =
 698         List.fold_left (tree_of_metho sch sign.cty_concr) csil fields
 699       in
 700       Octy_signature (self_ty, List.rev csil)
 701   | Tcty_fun (l, ty, cty) ->
 702       let lab = if !print_labels && l <> "" || is_optional l then l else "" in
 703       let ty =
 704        if is_optional l then
 705          match (repr ty).desc with
 706          | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
 707          | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
 708        else ty in
 709       let tr = tree_of_typexp sch ty in
 710       Octy_fun (lab, tr, tree_of_class_type sch params cty)
 711
 712 let class_type ppf cty =
 713   reset ();
 714   prepare_class_type [] cty;
 715   !Oprint.out_class_type ppf (tree_of_class_type false [] cty)
 716
 717 let tree_of_class_param param variance =
 718   (match tree_of_typexp true param with
 719     Otyp_var (_, s) -> s
 720   | _ -> "?"),
 721   if (repr param).desc = Tvar then (true, true) else variance
 722
 723 let tree_of_class_params params =
 724   let tyl = tree_of_typlist true params in
 725   List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
 726
 727 let tree_of_class_declaration id cl rs =
 728   let params = filter_params cl.cty_params in
 729
 730   reset ();
 731   List.iter add_alias params;
 732   prepare_class_type params cl.cty_type;
 733   let sty = self_type cl.cty_type in
 734   List.iter mark_loops params;
 735
 736   List.iter check_name_of_type (List.map proxy params);
 737   if is_aliased sty then check_name_of_type (proxy sty);
 738
 739   let vir_flag = cl.cty_new = None in
 740   Osig_class
 741     (vir_flag, Ident.name id,
 742      List.map2 tree_of_class_param params cl.cty_variance,
 743      tree_of_class_type true params cl.cty_type,
 744      tree_of_rec rs)
 745
 746 let class_declaration id ppf cl =
 747   !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
 748
 749 let tree_of_cltype_declaration id cl rs =
 750   let params = List.map repr cl.clty_params in
 751
 752   reset ();
 753   List.iter add_alias params;
 754   prepare_class_type params cl.clty_type;
 755   let sty = self_type cl.clty_type in
 756   List.iter mark_loops params;
 757
 758   List.iter check_name_of_type (List.map proxy params);
 759   if is_aliased sty then check_name_of_type (proxy sty);
 760
 761   let sign = Ctype.signature_of_class_type cl.clty_type in
 762
 763   let virt =
 764     let (fields, _) =
 765       Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
 766     List.exists
 767       (fun (lab, _, ty) ->
 768          not (lab = dummy_method || Concr.mem lab sign.cty_concr))
 769       fields
 770     || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false
 771   in
 772
 773   Osig_class_type
 774     (virt, Ident.name id,
 775      List.map2 tree_of_class_param params cl.clty_variance,
 776      tree_of_class_type true params cl.clty_type,
 777      tree_of_rec rs)
 778
 779 let cltype_declaration id ppf cl =
 780   !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
 781
 782 (* Print a module type *)
 783
 784 let rec tree_of_modtype = function
 785   | Tmty_ident p ->
 786       Omty_ident (tree_of_path p)
 787   | Tmty_signature sg ->
 788       Omty_signature (tree_of_signature sg)
 789   | Tmty_functor(param, ty_arg, ty_res) ->
 790       Omty_functor
 791         (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res)
 792
 793 and tree_of_signature = function
 794   | [] -> []
 795   | Tsig_value(id, decl) :: rem ->
 796       tree_of_value_description id decl :: tree_of_signature rem
 797   | Tsig_type(id, _, _) :: rem when is_row_name (Ident.name id) ->
 798       tree_of_signature rem
 799   | Tsig_type(id, decl, rs) :: rem ->
 800       Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
 801       tree_of_signature rem
 802   | Tsig_exception(id, decl) :: rem ->
 803       tree_of_exception_declaration id decl :: tree_of_signature rem
 804   | Tsig_module(id, mty, rs) :: rem ->
 805       Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
 806       tree_of_signature rem
 807   | Tsig_modtype(id, decl) :: rem ->
 808       tree_of_modtype_declaration id decl :: tree_of_signature rem
 809   | Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
 810       tree_of_class_declaration id decl rs :: tree_of_signature rem
 811   | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
 812       tree_of_cltype_declaration id decl rs :: tree_of_signature rem
 813   | _ ->
 814       assert false
 815
 816 and tree_of_modtype_declaration id decl =
 817   let mty =
 818     match decl with
 819     | Tmodtype_abstract -> Omty_abstract
 820     | Tmodtype_manifest mty -> tree_of_modtype mty
 821   in
 822   Osig_modtype (Ident.name id, mty)
 823
 824 let tree_of_module id mty rs =
 825   Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)
 826
 827 let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
 828 let modtype_declaration id ppf decl =
 829   !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl)
 830
 831 (* Print a signature body (used by -i when compiling a .ml) *)
 832
 833 let print_signature ppf tree =
 834   fprintf ppf "@[<v>%a@]" !Oprint.out_signature tree
 835
 836 let signature ppf sg =
 837   fprintf ppf "%a" print_signature (tree_of_signature sg)
 838
 839 (* Print an unification error *)
 840
 841 let type_expansion t ppf t' =
 842   if t == t' then type_expr ppf t else
 843   let t' = if proxy t == proxy t' then unalias t' else t' in
 844   fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
 845
 846 let rec trace fst txt ppf = function
 847   | (t1, t1') :: (t2, t2') :: rem ->
 848       if not fst then fprintf ppf "@,";
 849       fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
 850        (type_expansion t1) t1' txt (type_expansion t2) t2'
 851        (trace false txt) rem
 852   | _ -> ()
 853
 854 let rec filter_trace = function
 855   | (t1, t1') :: (t2, t2') :: rem ->
 856       let rem' = filter_trace rem in
 857       if t1 == t1' && t2 == t2'
 858       then rem'
 859       else (t1, t1') :: (t2, t2') :: rem'
 860   | _ -> []
 861
 862 (* Hide variant name and var, to force printing the expanded type *)
 863 let hide_variant_name t =
 864   match repr t with
 865   | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
 866       newty2 t.level
 867         (Tvariant {(row_repr row) with row_name = None;
 868                    row_more = newty2 (row_more row).level Tvar})
 869   | _ -> t
 870
 871 let prepare_expansion (t, t') =
 872   let t' = hide_variant_name t' in
 873   mark_loops t; if t != t' then mark_loops t';
 874   (t, t')
 875
 876 let may_prepare_expansion compact (t, t') =
 877   match (repr t').desc with
 878     Tvariant _ | Tobject _ when compact ->
 879       mark_loops t; (t, t)
 880   | _ -> prepare_expansion (t, t')
 881
 882 let print_tags ppf fields =
 883   match fields with [] -> ()
 884   | (t, _) :: fields ->
 885       fprintf ppf "`%s" t;
 886       List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
 887
 888 let has_explanation unif t3 t4 =
 889   match t3.desc, t4.desc with
 890     Tfield _, _ | _, Tfield _
 891   | Tunivar, Tvar | Tvar, Tunivar
 892   | Tvariant _, Tvariant _ -> true
 893   | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
 894       unif && min t3.level t4.level < Path.binding_time p
 895   | _ -> false
 896
 897 let rec mismatch unif = function
 898     (_, t) :: (_, t') :: rem ->
 899       begin match mismatch unif rem with
 900         Some _ as m -> m
 901       | None ->
 902           if has_explanation unif t t' then Some(t,t') else None
 903       end
 904   | [] -> None
 905   | _ -> assert false
 906
 907 let explanation unif t3 t4 ppf =
 908   match t3.desc, t4.desc with
 909   | Tfield _, Tvar | Tvar, Tfield _ ->
 910       fprintf ppf "@,Self type cannot escape its class"
 911   | Tconstr (p, _, _), Tvar
 912     when unif && t4.level < Path.binding_time p ->
 913       fprintf ppf
 914         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
 915         path p
 916   | Tvar, Tconstr (p, _, _)
 917     when unif && t3.level < Path.binding_time p ->
 918       fprintf ppf
 919         "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
 920         path p
 921   | Tvar, Tunivar | Tunivar, Tvar ->
 922       fprintf ppf "@,The universal variable %a would escape its scope"
 923         type_expr (if t3.desc = Tunivar then t3 else t4)
 924   | Tfield (lab, _, _, _), _
 925   | _, Tfield (lab, _, _, _) when lab = dummy_method ->
 926       fprintf ppf
 927         "@,Self type cannot be unified with a closed object type"
 928   | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' ->
 929       fprintf ppf "@,Types for method %s are incompatible" l
 930   | _, Tfield (l, _, _, _) ->
 931       fprintf ppf
 932         "@,@[The first object type has no method %s@]" l
 933   | Tfield (l, _, _, _), _ ->
 934       fprintf ppf
 935         "@,@[The second object type has no method %s@]" l
 936   | Tvariant row1, Tvariant row2 ->
 937       let row1 = row_repr row1 and row2 = row_repr row2 in
 938       begin match
 939         row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with
 940       | [], true, [], true ->
 941           fprintf ppf "@,These two variant types have no intersection"
 942       | [], true, fields, _ ->
 943           fprintf ppf
 944             "@,@[The first variant type does not allow tag(s)@ @[<hov>%a@]@]"
 945             print_tags fields
 946       | fields, _, [], true ->
 947           fprintf ppf
 948             "@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
 949             print_tags fields
 950       | [l1,_], true, [l2,_], true when l1 = l2 ->
 951           fprintf ppf "@,Types for tag `%s are incompatible" l1
 952       | _ -> ()
 953       end
 954   | _ -> ()
 955
 956 let explanation unif mis ppf =
 957   match mis with
 958     None -> ()
 959   | Some (t3, t4) -> explanation unif t3 t4 ppf
 960
 961 let unification_error unif tr txt1 ppf txt2 =
 962   reset ();
 963   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
 964   let mis = mismatch unif tr in
 965   match tr with
 966   | [] | _ :: [] -> assert false
 967   | t1 :: t2 :: tr ->
 968     try
 969       let tr = filter_trace tr in
 970       let t1, t1' = may_prepare_expansion (tr = []) t1
 971       and t2, t2' = may_prepare_expansion (tr = []) t2 in
 972       print_labels := not !Clflags.classic;
 973       let tr = List.map prepare_expansion tr in
 974       fprintf ppf
 975         "@[<v>\
 976           @[%t@;<1 2>%a@ \
 977             %t@;<1 2>%a\
 978           @]%a%t\
 979          @]"
 980         txt1 (type_expansion t1) t1'
 981         txt2 (type_expansion t2) t2'
 982         (trace false "is not compatible with type") tr
 983         (explanation unif mis);
 984       print_labels := true
 985     with exn ->
 986       print_labels := true;
 987       raise exn
 988
 989 let report_unification_error ppf tr txt1 txt2 =
 990   unification_error true tr txt1 ppf txt2;;
 991
 992 let trace fst txt ppf tr =
 993   print_labels := not !Clflags.classic;
 994   try match tr with
 995     t1 :: t2 :: tr' ->
 996       if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr')
 997       else trace fst txt ppf (filter_trace tr);
 998       print_labels := true
 999   | _ -> ()
1000   with exn ->
1001     print_labels := true;
1002     raise exn
1003
1004 let report_subtyping_error ppf tr1 txt1 tr2 =
1005   reset ();
1006   let tr1 = List.map prepare_expansion tr1
1007   and tr2 = List.map prepare_expansion tr2 in
1008   trace true txt1 ppf tr1;
1009   if tr2 = [] then () else
1010   let mis = mismatch true tr2 in
1011   trace false "is not compatible with type" ppf tr2;
1012   explanation true mis ppf