hphp/hack/src/typing/typing_log.ml

   1 (*
   2  * Copyright (c) 2016, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the MIT license found in the
   6  * LICENSE file in the "hack" directory of this source tree.
   7  *
   8  *)
   9
  10 open Hh_prelude
  11 open Typing_defs
  12 open Typing_env_types
  13 module Inf = Typing_inference_env
  14 module Pr = Typing_print
  15 module TPEnv = Type_parameter_env
  16 module TySet = Typing_set
  17 open Tty
  18 open Typing_log_value
  19
  20 (*****************************************************************************)
  21 (* Logging type inference environment                                        *)
  22 (*****************************************************************************)
  23
  24 (* Eventual input to Tty.cprint *)
  25 let out_channel = ref stdout
  26
  27 let logBuffer = ref []
  28
  29 let indentLevel = ref 0
  30
  31 let accumulatedLength = ref 0
  32
  33 let lnewline () =
  34   match !logBuffer with
  35   | [] -> ()
  36   | _ ->
  37     cprint
  38       ~out_channel:!out_channel
  39       ~color_mode:Color_Auto
  40       ((Normal White, String.make (2 * !indentLevel) ' ')
  41        :: List.rev ((Normal White, "\n") :: !logBuffer));
  42     Out_channel.flush !out_channel;
  43     accumulatedLength := 0;
  44     logBuffer := []
  45
  46 let lprintf c =
  47   Printf.ksprintf (fun s ->
  48       let len = String.length s in
  49       logBuffer := (c, s) :: !logBuffer;
  50       if !accumulatedLength + len > 80 then
  51         lnewline ()
  52       else
  53         accumulatedLength := !accumulatedLength + len)
  54
  55 let lnewline_open () =
  56   lnewline ();
  57   indentLevel := !indentLevel + 1
  58
  59 let lnewline_close () =
  60   lnewline ();
  61   indentLevel := !indentLevel - 1
  62
  63 let indentEnv ?(color = Normal Yellow) message f =
  64   lnewline ();
  65   lprintf color "%s" message;
  66   lnewline_open ();
  67   f ();
  68   lnewline_close ()
  69
  70 (* Most recent environment. We only display diffs *)
  71 let lastenv =
  72   ref
  73     (Typing_env_types.empty
  74        (Provider_context.empty_for_debugging
  75           ~popt:ParserOptions.default
  76           ~tcopt:TypecheckerOptions.default
  77           ~deps_mode:(Typing_deps_mode.InMemoryMode None))
  78        Relative_path.default
  79        ~droot:None)
  80
  81 let iterations : int Pos.Map.t ref = ref Pos.Map.empty
  82
  83 let iterations_decl : int Pos_or_decl.Map.t ref = ref Pos_or_decl.Map.empty
  84
  85 (* Universal representation of a delta between values
  86  *)
  87 type delta =
  88   | Updated of value (* For bools, atoms, lists, replaced sets, replaced maps *)
  89   | Unchanged
  90   (* Set has had some elements removed, some added *)
  91   | Set_delta of {
  92       added: SSet.t;
  93       removed: SSet.t;
  94     }
  95   (* Map has some new keys, some removed keys, and deltas to existing keys.
  96    * All other keys assumed to be unchanged.
  97    *)
  98   | Map_delta of {
  99       added: value SMap.t;
 100       removed: SSet.t;
 101       changed: delta SMap.t;
 102     }
 103
 104 let rec compute_value_delta (oldval : value) (newval : value) : delta =
 105   match (oldval, newval) with
 106   | (Bool b1, Bool b2) ->
 107     if Bool.equal b1 b2 then
 108       Unchanged
 109     else
 110       Updated newval
 111   | (Atom s1, Atom s2) ->
 112     if String.equal s1 s2 then
 113       Unchanged
 114     else
 115       Updated newval
 116   | (Type t1, Type t2) ->
 117     if equal_internal_type t1 t2 then
 118       Unchanged
 119     else
 120       Updated newval
 121   | (SubtypeProp p1, SubtypeProp p2) ->
 122     if Typing_logic.equal_subtype_prop p1 p2 then
 123       Unchanged
 124     else
 125       Updated newval
 126   | (Set s1, Set s2) ->
 127     let added = SSet.diff s2 s1 in
 128     let removed = SSet.diff s1 s2 in
 129     if SSet.is_empty added && SSet.is_empty removed then
 130       Unchanged
 131     else
 132       Set_delta { added; removed }
 133   | (List l1, List l2) ->
 134     if List.equal equal_value l1 l2 then
 135       Unchanged
 136     else
 137       Updated newval
 138   | (Map m1, Map m2) ->
 139     let removed =
 140       SMap.fold
 141         (fun i _ s ->
 142           match SMap.find_opt i m2 with
 143           | None -> SSet.add i s
 144           | Some _ -> s)
 145         m1
 146         SSet.empty
 147     in
 148     let added =
 149       SMap.fold
 150         (fun i v m ->
 151           match SMap.find_opt i m1 with
 152           | None -> SMap.add i v m
 153           | _ -> m)
 154         m2
 155         SMap.empty
 156     in
 157     let changed =
 158       SMap.fold
 159         (fun i oldx m ->
 160           match SMap.find_opt i m2 with
 161           | None -> m
 162           | Some newx ->
 163             (match compute_value_delta oldx newx with
 164             | Unchanged -> m
 165             | d -> SMap.add i d m))
 166         m1
 167         SMap.empty
 168     in
 169     if SSet.is_empty removed && SMap.is_empty added && SMap.is_empty changed
 170     then
 171       Unchanged
 172     else
 173       Map_delta { removed; added; changed }
 174   (* Type has changed! *)
 175   | (_, _) -> Updated newval
 176
 177 let is_leaf_value v =
 178   match v with
 179   | Atom _
 180   | Bool _
 181   | List _ ->
 182     true
 183   | Map m when SMap.is_empty m -> true
 184   | Set _ -> true
 185   | _ -> false
 186
 187 let log_key key = lprintf (Normal Yellow) "%s" key
 188
 189 let log_sset s =
 190   match SSet.elements s with
 191   | [] -> lprintf (Normal Green) "{}"
 192   | [s] -> lprintf (Normal Green) "{%s}" s
 193   | s :: ss ->
 194     lprintf (Normal Green) "{";
 195     lprintf (Normal Green) "%s" s;
 196     List.iter ss ~f:(fun s -> lprintf (Normal Green) ",%s" s);
 197     lprintf (Normal Green) "}"
 198
 199 let rec log_value env value =
 200   match value with
 201   | Atom s -> lprintf (Normal Green) "%s" s
 202   | Bool b ->
 203     lprintf
 204       (Normal Green)
 205       "%s"
 206       (if b then
 207         "true"
 208       else
 209         "false")
 210   | List [] -> lprintf (Normal Green) "[]"
 211   | List (v :: vs) ->
 212     lprintf (Normal Green) "[";
 213     log_value env v;
 214     List.iter vs ~f:(fun v ->
 215         lprintf (Normal Green) ",";
 216         log_value env v);
 217     lprintf (Normal Green) "]"
 218   | Map m ->
 219     if SMap.is_empty m then
 220       lprintf (Normal Green) "{}"
 221     else
 222       SMap.iter (log_key_value env "") m
 223   | Set s -> log_sset s
 224   | Type ty -> Typing_print.debug_i env ty |> lprintf (Normal Green) "%s"
 225   | SubtypeProp prop ->
 226     Typing_print.subtype_prop env prop |> lprintf (Normal Green) "%s"
 227
 228 and log_key_value env prefix k v =
 229   if is_leaf_value v then (
 230     lprintf (Normal Green) "%s" prefix;
 231     log_key k;
 232     lprintf (Normal Yellow) " ";
 233     log_value env v;
 234     lnewline ()
 235   ) else (
 236     lnewline ();
 237     lprintf (Normal Green) "%s" prefix;
 238     log_key k;
 239     lnewline_open ();
 240     log_value env v;
 241     lnewline_close ()
 242   )
 243
 244 let is_leaf_delta d =
 245   match d with
 246   | Updated v -> is_leaf_value v
 247   (* | Added d | Removed d | Updated d -> is_leaf_delta d*)
 248   | _ -> false
 249
 250 let rec log_delta env delta =
 251   match delta with
 252   | Updated v -> log_value env v
 253   | Unchanged -> ()
 254   | Set_delta { added; removed } ->
 255     if not (SSet.is_empty added) then (
 256       lprintf (Bold Green) " += ";
 257       log_sset added
 258     );
 259     if not (SSet.is_empty removed) then (
 260       lprintf (Bold Red) " -= ";
 261       log_sset removed
 262     )
 263   | Map_delta { added; removed; changed } ->
 264     SSet.iter
 265       (fun k ->
 266         lprintf (Bold Red) "-";
 267         log_key k;
 268         lnewline ())
 269       removed;
 270     SMap.iter (log_key_value env "+") added;
 271     SMap.iter (log_key_delta env) changed
 272
 273 and log_key_delta env k d =
 274   if is_leaf_delta d then (
 275     log_key k;
 276     lprintf (Normal Yellow) " ";
 277     log_delta env d;
 278     lnewline ()
 279   ) else (
 280     lnewline ();
 281     log_key k;
 282     lprintf (Normal Yellow) " ";
 283     lnewline_open ();
 284     log_delta env d;
 285     lnewline_close ()
 286   )
 287
 288 let type_as_value env ty = Atom (Typing_print.debug env ty)
 289
 290 let decl_type_as_value env ty = Atom (Typing_print.debug_decl env ty)
 291
 292 let possibly_enforced_type_as_value env et =
 293   Atom
 294     ((match et.et_enforced with
 295      | Enforced -> "enforced "
 296      | Unenforced -> "")
 297     ^ Typing_print.debug env et.et_type)
 298
 299 let return_info_as_value env return_info =
 300   let Typing_env_return_info.{ return_type; return_disposable } = return_info in
 301   make_map
 302     [
 303       ("return_type", possibly_enforced_type_as_value env return_type);
 304       ("return_disposable", Bool return_disposable);
 305     ]
 306
 307 let local_id_map_as_value f m =
 308   Map
 309     (Local_id.Map.fold
 310        (fun id x m -> SMap.add (local_id_as_string id) (f x) m)
 311        m
 312        SMap.empty)
 313
 314 let reify_kind_as_value k =
 315   string_as_value
 316     (match k with
 317     | Aast.Erased -> "erased"
 318     | Aast.SoftReified -> "soft_reified"
 319     | Aast.Reified -> "reified")
 320
 321 let tyset_as_value env tys =
 322   Set
 323     (TySet.fold
 324        (fun t s -> SSet.add (Typing_print.debug env t) s)
 325        tys
 326        SSet.empty)
 327
 328 let rec tparam_info_as_value env tpinfo =
 329   let Typing_kinding_defs.
 330         {
 331           lower_bounds;
 332           upper_bounds;
 333           reified;
 334           enforceable;
 335           newable;
 336           require_dynamic;
 337           parameters;
 338         } =
 339     tpinfo
 340   in
 341   make_map
 342     [
 343       ("lower_bounds", tyset_as_value env lower_bounds);
 344       ("upper_bounds", tyset_as_value env upper_bounds);
 345       ("reified", reify_kind_as_value reified);
 346       ("enforceable", bool_as_value enforceable);
 347       ("newable", bool_as_value newable);
 348       ("require_dynamic", bool_as_value require_dynamic);
 349       ("parameters", named_tparam_info_list_as_value env parameters);
 350     ]
 351
 352 and named_tparam_info_list_as_value env parameters =
 353   let param_values =
 354     List.map parameters ~f:(fun (name, param) ->
 355         list_as_value
 356           [string_as_value (snd name); tparam_info_as_value env param])
 357   in
 358   list_as_value param_values
 359
 360 let tpenv_as_value env tpenv =
 361   make_map
 362     [
 363       ( "tparams",
 364         Map
 365           (TPEnv.fold
 366              (fun name tpinfo m ->
 367                SMap.add name (tparam_info_as_value env tpinfo) m)
 368              tpenv
 369              SMap.empty) );
 370       ("consistent", bool_as_value (TPEnv.is_consistent tpenv));
 371     ]
 372
 373 let per_cont_entry_as_value env f entry =
 374   make_map
 375     [
 376       ( "local_types",
 377         local_id_map_as_value f entry.Typing_per_cont_env.local_types );
 378       ( "fake_members",
 379         Typing_fake_members.as_log_value entry.Typing_per_cont_env.fake_members
 380       );
 381       ("tpenv", tpenv_as_value env entry.Typing_per_cont_env.tpenv);
 382     ]
 383
 384 let continuations_map_as_value f m =
 385   Map
 386     (Typing_continuations.Map.fold
 387        (fun k x m -> SMap.add (Typing_continuations.to_string k) (f x) m)
 388        m
 389        SMap.empty)
 390
 391 let local_as_value env (ty, _pos, expr_id) =
 392   Atom (Printf.sprintf "%s [expr_id=%d]" (Typing_print.debug env ty) expr_id)
 393
 394 let per_cont_env_as_value env per_cont_env =
 395   continuations_map_as_value
 396     (per_cont_entry_as_value env (local_as_value env))
 397     per_cont_env
 398
 399 let log_position p ?function_name f =
 400   let n =
 401     match Pos.Map.find_opt p !iterations with
 402     | None ->
 403       iterations := Pos.Map.add p 1 !iterations;
 404       1
 405     | Some n ->
 406       iterations := Pos.Map.add p (n + 1) !iterations;
 407       n + 1
 408   in
 409   (* If we've hit this many iterations then something must have gone wrong
 410    * so let's not bother spewing to the log *)
 411   if n > 10000 then
 412     ()
 413   else
 414     indentEnv
 415       ~color:(Bold Yellow)
 416       ((Pos.string @@ Pos.to_absolute p)
 417       ^ (if Int.equal n 1 then
 418           ""
 419         else
 420           "[" ^ string_of_int n ^ "]")
 421       ^
 422       match function_name with
 423       | None -> ""
 424       | Some n -> " {" ^ n ^ "}")
 425       f
 426
 427 let log_pos_or_decl p ?function_name f =
 428   let n =
 429     match Pos_or_decl.Map.find_opt p !iterations_decl with
 430     | None ->
 431       iterations_decl := Pos_or_decl.Map.add p 1 !iterations_decl;
 432       1
 433     | Some n ->
 434       iterations_decl := Pos_or_decl.Map.add p (n + 1) !iterations_decl;
 435       n + 1
 436   in
 437   (* If we've hit this many iterations then something must have gone wrong
 438    * so let's not bother spewing to the log *)
 439   if n > 10000 then
 440     ()
 441   else
 442     indentEnv
 443       ~color:(Bold Yellow)
 444       (Pos_or_decl.show_as_absolute_file_line_characters p
 445       ^ (if Int.equal n 1 then
 446           ""
 447         else
 448           "[" ^ string_of_int n ^ "]")
 449       ^
 450       match function_name with
 451       | None -> ""
 452       | Some n -> " {" ^ n ^ "}")
 453       f
 454
 455 let log_with_level env key ~level log_f =
 456   if Typing_env_types.get_log_level env key >= level then
 457     log_f ()
 458   else
 459     ()
 460
 461 let log_subtype_prop env message prop =
 462   lprintf (Tty.Bold Tty.Green) "%s: " message;
 463   lprintf (Tty.Normal Tty.Green) "%s" (Typing_print.subtype_prop env prop);
 464   lnewline ()
 465
 466 let fun_kind_to_string k =
 467   match k with
 468   | Ast_defs.FSync -> "normal"
 469   | Ast_defs.FAsync -> "async"
 470   | Ast_defs.FGenerator -> "generator"
 471   | Ast_defs.FAsyncGenerator -> "async generator"
 472
 473 let val_kind_to_string k =
 474   match k with
 475   | Other -> "other"
 476   | Lval -> "lval"
 477   | LvalSubexpr -> "lval subexpression"
 478
 479 let lenv_as_value env lenv =
 480   let { per_cont_env; local_using_vars } = lenv in
 481   make_map
 482     [
 483       ("per_cont_env", per_cont_env_as_value env per_cont_env);
 484       ("local_using_vars", local_id_set_as_value local_using_vars);
 485     ]
 486
 487 let param_as_value env (ty, _pos, ty_opt) =
 488   let ty_str = Typing_print.debug env ty in
 489   match ty_opt with
 490   | None -> Atom ty_str
 491   | Some ty2 ->
 492     let ty2_str = Typing_print.debug env ty2 in
 493     Atom (Printf.sprintf "%s inout %s" ty_str ty2_str)
 494
 495 let genv_as_value env genv =
 496   let {
 497     tcopt = _;
 498     callable_pos;
 499     readonly;
 500     return;
 501     params;
 502     condition_types;
 503     parent;
 504     self;
 505     static;
 506     val_kind;
 507     fun_kind;
 508     fun_is_ctor;
 509     file = _;
 510     this_module;
 511     this_internal;
 512     this_support_dynamic_type;
 513   } =
 514     genv
 515   in
 516   make_map
 517     ([
 518        ("readonly", bool_as_value readonly);
 519        ("return", return_info_as_value env return);
 520        ("callable_pos", pos_as_value callable_pos);
 521        ("params", local_id_map_as_value (param_as_value env) params);
 522        ( "condition_types",
 523          smap_as_value (decl_type_as_value env) condition_types );
 524        ("static", bool_as_value static);
 525        ("val_kind", string_as_value (val_kind_to_string val_kind));
 526        ("fun_kind", string_as_value (fun_kind_to_string fun_kind));
 527        ("fun_is_ctor", bool_as_value fun_is_ctor);
 528        ("this_internal", bool_as_value this_internal);
 529        ("this_support_dynamic_type", bool_as_value this_support_dynamic_type);
 530      ]
 531     @ (match this_module with
 532       | Some this_module ->
 533         [("this_module", string_as_value @@ Ast_defs.show_id this_module)]
 534       | None -> [])
 535     @ (match parent with
 536       | Some (parent_id, parent_ty) ->
 537         [
 538           ("parent_id", string_as_value parent_id);
 539           ("parent_ty", decl_type_as_value env parent_ty);
 540         ]
 541       | None -> [])
 542     @
 543     match self with
 544     | Some (self_id, self_ty) ->
 545       [
 546         ("self_id", string_as_value self_id);
 547         ("self_ty", type_as_value env self_ty);
 548       ]
 549     | None -> [])
 550
 551 let fun_tast_info_as_map = function
 552   | None -> make_map []
 553   | Some r ->
 554     let open Tast in
 555     let { has_implicit_return; has_readonly } = r in
 556     make_map
 557       [
 558         ("has_implicit_return", bool_as_value has_implicit_return);
 559         ("has_readonly", bool_as_value has_readonly);
 560       ]
 561
 562 let env_as_value env =
 563   let {
 564     fresh_typarams;
 565     lenv;
 566     genv;
 567     decl_env = _;
 568     tracing_info = _;
 569     in_loop;
 570     in_try;
 571     in_expr_tree;
 572     inside_constructor;
 573     in_support_dynamic_type_method_check;
 574     tpenv;
 575     log_levels = _;
 576     allow_wildcards;
 577     inference_env;
 578     big_envs = _;
 579     fun_tast_info;
 580   } =
 581     env
 582   in
 583   make_map
 584     [
 585       ("fresh_typarams", Set fresh_typarams);
 586       ("lenv", lenv_as_value env lenv);
 587       ("genv", genv_as_value env genv);
 588       ("in_loop", bool_as_value in_loop);
 589       ("in_try", bool_as_value in_try);
 590       ("in_expr_tree", bool_as_value in_expr_tree);
 591       ("inside_constructor", bool_as_value inside_constructor);
 592       ( "in_support_dynamic_type_method_check",
 593         bool_as_value in_support_dynamic_type_method_check );
 594       ("tpenv", tpenv_as_value env tpenv);
 595       ("allow_wildcards", bool_as_value allow_wildcards);
 596       ( "inference_env",
 597         Typing_inference_env.Log.inference_env_as_value inference_env );
 598       ("fun_tast_info", fun_tast_info_as_map fun_tast_info);
 599     ]
 600
 601 let log_env_diff p ?function_name old_env new_env =
 602   let value = env_as_value new_env in
 603   let old_value = env_as_value old_env in
 604   let d = compute_value_delta old_value value in
 605   match d with
 606   | Unchanged -> ()
 607   | _ -> log_position p ?function_name (fun () -> log_delta new_env d)
 608
 609 (* Log the environment: local_types, subst, tenv and tpenv *)
 610 let hh_show_env ?function_name p env =
 611   log_with_level env "show" ~level:0 @@ fun () ->
 612   let old_env = !lastenv in
 613   lastenv := env;
 614   log_env_diff ?function_name p old_env env
 615
 616 let hh_show_full_env p env =
 617   log_with_level env "show" ~level:0 @@ fun () ->
 618   let empty_env =
 619     { env with inference_env = Typing_inference_env.empty_inference_env }
 620   in
 621   log_env_diff p empty_env env
 622
 623 (* Log the type of an expression *)
 624 let hh_show p env ty =
 625   log_with_level env "show" ~level:0 @@ fun () ->
 626   let s1 = Pr.with_blank_tyvars (fun () -> Pr.debug env ty) in
 627   let s2 = Typing_print.constraints_for_type env ty in
 628   log_position p (fun () ->
 629       lprintf (Normal Green) "%s" s1;
 630       if String.( <> ) s2 "" then lprintf (Normal Green) " %s" s2;
 631       lnewline ())
 632
 633 (* Simple type of possible log data *)
 634 type log_structure =
 635   | Log_head of string * log_structure list
 636   | Log_type of string * Typing_defs.locl_ty
 637   | Log_decl_type of string * Typing_defs.decl_ty
 638   | Log_type_i of string * Typing_defs.internal_type
 639
 640 let log_types p env items =
 641   log_pos_or_decl p (fun () ->
 642       let rec go items =
 643         List.iter items ~f:(fun item ->
 644             match item with
 645             | Log_head (message, items) ->
 646               indentEnv ~color:(Normal Yellow) message (fun () -> go items)
 647             | Log_type (message, ty) ->
 648               let s = Typing_print.debug env ty in
 649               lprintf (Bold Green) "%s: " message;
 650               lprintf (Normal Green) "%s" s;
 651               lnewline ()
 652             | Log_decl_type (message, ty) ->
 653               let s = Typing_print.debug_decl env ty in
 654               lprintf (Bold Green) "%s: " message;
 655               lprintf (Normal Green) "%s" s;
 656               lnewline ()
 657             | Log_type_i (message, ty) ->
 658               let s = Typing_print.debug_i env ty in
 659               lprintf (Bold Green) "%s: " message;
 660               lprintf (Normal Green) "%s" s;
 661               lnewline ())
 662       in
 663       go items)
 664
 665 let log_escape ?(level = 1) p env msg vars =
 666   log_with_level env "escape" ~level (fun () ->
 667       log_pos_or_decl p (fun () ->
 668           indentEnv ~color:(Normal Yellow) msg (fun () -> ());
 669           if not (List.is_empty vars) then (
 670             lnewline ();
 671             List.iter vars ~f:(lprintf (Normal Green) "%s ")
 672           )))
 673
 674 let log_global_inference_env p env global_tvenv =
 675   log_position p (fun () ->
 676       log_value env @@ Inf.Log.global_inference_env_as_value global_tvenv)
 677
 678 let log_prop level p message env prop =
 679   log_with_level env "prop" ~level (fun () ->
 680       log_pos_or_decl p (fun () -> log_subtype_prop env message prop))
 681
 682 let log_new_tvar env p tvar message =
 683   log_with_level env "prop" ~level:2 (fun () ->
 684       log_types
 685         (Pos_or_decl.of_raw_pos p)
 686         env
 687         [Log_head (message, [Log_type ("type variable", tvar)])])
 688
 689 let log_tparam_instantiation env p tparam_name tvar =
 690   let message =
 691     Printf.sprintf "Instantiating type parameter %s with" tparam_name
 692   in
 693   log_new_tvar env p tvar message
 694
 695 let log_new_tvar_for_new_object env p tvar cname tparam =
 696   let message =
 697     Printf.sprintf
 698       "Creating new type var for type parameter %s while instantiating object %s"
 699       (snd tparam.tp_name)
 700       (snd cname)
 701   in
 702   log_new_tvar env p tvar message
 703
 704 let log_new_tvar_for_tconst env (p, tvar) (_p, tconstid) tvar_for_tconst =
 705   let message =
 706     Printf.sprintf "Creating new type var for #%d::%s" tvar tconstid
 707   in
 708   log_new_tvar env p tvar_for_tconst message
 709
 710 let log_new_tvar_for_tconst_access env p tvar class_name (_p, tconst) =
 711   let message =
 712     Printf.sprintf
 713       "Creating type var with the same constraints as %s::%s"
 714       class_name
 715       tconst
 716   in
 717   log_new_tvar env p tvar message
 718
 719 let log_intersection ~level env r ty1 ty2 ~inter_ty =
 720   log_with_level env "inter" ~level (fun () ->
 721       log_types
 722         (Reason.to_pos r)
 723         env
 724         [
 725           Log_head
 726             ( "Intersecting",
 727               [
 728                 Log_type ("ty1", ty1);
 729                 Log_type ("ty2", ty2);
 730                 Log_type ("intersection", inter_ty);
 731               ] );
 732         ])
 733
 734 let log_type_access ~level root (p, type_const_name) (env, result_ty) =
 735   ( log_with_level env "tyconst" ~level @@ fun () ->
 736     log_types
 737       p
 738       env
 739       [
 740         Log_head
 741           ( "Accessing type constant " ^ type_const_name ^ " of",
 742             [Log_type ("type", root); Log_type ("result", result_ty)] );
 743       ] );
 744   (env, result_ty)
 745
 746 let log_localize ~level ety_env (decl_ty : decl_ty) (env, result_ty) =
 747   ( log_with_level env "localize" ~level @@ fun () ->
 748     log_types
 749       (get_pos result_ty)
 750       env
 751       [
 752         Log_head
 753           ( "Localizing",
 754             [
 755               Log_head
 756                 ( Printf.sprintf
 757                     "expand_visible_newtype: %b"
 758                     ety_env.expand_visible_newtype,
 759                   [] );
 760               Log_decl_type ("decl type", decl_ty);
 761               Log_type ("result", result_ty);
 762             ] );
 763       ] );
 764   (env, result_ty)
 765
 766 let log_pessimise_ ?(level = 1) env kind pos name =
 767   log_with_level env "pessimise" ~level @@ fun () ->
 768   let p = Pos_or_decl.unsafe_to_raw_pos pos in
 769   let (file, line) =
 770     let p = Pos.to_absolute p in
 771     (Pos.filename p, Pos.line p)
 772   in
 773   lnewline ();
 774   lprintf (Normal Yellow) "pessimise:\t%s,%s,%d,%s" kind file line name;
 775   lnewline ()
 776
 777 let log_pessimise_prop env pos prop_name =
 778   log_pessimise_ env "prop" (Pos_or_decl.of_raw_pos pos) ("$" ^ prop_name)
 779
 780 let log_pessimise_param env ~is_promoted_property pos mode param_name =
 781   if
 782     is_promoted_property
 783     || (match mode with
 784        | Ast_defs.Pinout _ -> true
 785        | _ -> false)
 786     || Typing_env_types.get_log_level env "pessimise.params" >= 1
 787   then
 788     log_pessimise_
 789       env
 790       (if is_promoted_property then
 791         "prop"
 792       else
 793         "param")
 794       (Pos_or_decl.of_raw_pos pos)
 795       param_name
 796
 797 let log_pessimise_return ?level env pos =
 798   log_pessimise_ ?level env "ret" (Pos_or_decl.of_raw_pos pos) ""
 799
 800 let increment_feature_count env s =
 801   if TypecheckerOptions.language_feature_logging env.genv.tcopt then
 802     Measure.sample s 1.0
 803
 804 module GlobalInference = struct
 805   let log_cat = "gi"
 806
 807   let log_merging_subgraph env pos =
 808     log_with_level env log_cat ~level:1 (fun () ->
 809         log_position pos (fun () ->
 810             log_key "merging subgraph for function at this position"))
 811
 812   let log_merging_var env pos var =
 813     log_with_level env log_cat ~level:1 (fun () ->
 814         log_position pos (fun () ->
 815             log_key (Printf.sprintf "merging type variable %d" var)))
 816 end
 817
 818 module GI = GlobalInference