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 Core_kernel
  11 module Env = Typing_env
  12
  13 open Tty
  14
  15 (*****************************************************************************)
  16 (* Logging type inference environment                                        *)
  17 (*****************************************************************************)
  18
  19 (* Eventual input to Tty.cprint *)
  20 let out_channel = ref stdout
  21 let logBuffer = ref []
  22 let indentLevel = ref 0
  23 let accumulatedLength = ref 0
  24 let lnewline () =
  25   match !logBuffer with
  26   | [] -> ()
  27   | _ ->
  28     begin
  29       cprint ~out_channel:!out_channel ~color_mode:Color_Auto
  30         ((Normal White, String.make (2 * !indentLevel) ' ') ::
  31            List.rev ((Normal White, "\n") :: !logBuffer));
  32        accumulatedLength := 0;
  33       logBuffer := []
  34     end
  35
  36 let lprintf c =
  37   Printf.ksprintf (fun s ->
  38     let len = String.length s in
  39     logBuffer := (c,s) :: !logBuffer;
  40     if !accumulatedLength + len > 80
  41     then lnewline ()
  42     else accumulatedLength := !accumulatedLength + len)
  43
  44 let indentEnv ?(color=Normal Yellow) message f =
  45   lnewline ();
  46   lprintf color "%s" message;
  47   lnewline ();
  48   indentLevel := !indentLevel + 1;
  49   f ();
  50   lnewline ();
  51   indentLevel := !indentLevel - 1
  52
  53 (* Most recent environment. We only display diffs *)
  54 let lastenv =ref (Env.empty TypecheckerOptions.default
  55   Relative_path.default None)
  56 let iterations: int Pos.Map.t ref = ref Pos.Map.empty
  57
  58 (* Log all changes to subst *)
  59 let log_subst_diff oldSubst newSubst =
  60   indentEnv (Printf.sprintf
  61     "subst(changes; old size = %d; new size = %d; size change = %d)"
  62     (IMap.cardinal oldSubst) (IMap.cardinal newSubst)
  63     (IMap.cardinal newSubst - IMap.cardinal oldSubst))
  64     (fun () ->
  65   begin
  66     IMap.iter (fun n n' ->
  67       match IMap.get n oldSubst with
  68       | None ->
  69         begin
  70           lprintf (Bold Green) "#%d: " n;
  71           lprintf (Normal Green) "#%d; " n'
  72         end
  73       | Some n'' ->
  74         if n'=n''
  75         then ()
  76         else
  77           begin
  78             lprintf (Bold Green) "#%d: " n';
  79             lprintf (Normal Green) "#%d; " n'
  80           end
  81     ) newSubst;
  82     IMap.iter (fun n _n' ->
  83       if IMap.mem n newSubst then ()
  84       else lprintf (Normal Red) "#%d deleted; " n) oldSubst
  85   end)
  86
  87 (* Log all changes to tenv *)
  88 let log_tenv_diff oldEnv newEnv =
  89   indentEnv (Printf.sprintf
  90     "tenv(changes; old size = %d; new size = %d; size change = %d)"
  91     (IMap.cardinal oldEnv.Env.tenv) (IMap.cardinal newEnv.Env.tenv)
  92     (IMap.cardinal newEnv.Env.tenv - IMap.cardinal oldEnv.Env.tenv))
  93     (fun () ->
  94   begin
  95     IMap.iter (fun n t ->
  96       match IMap.get n oldEnv.Env.tenv with
  97       | None ->
  98         begin
  99           lprintf (Bold Green) "#%d: " n;
 100           lprintf (Normal Green) "%s; " (Typing_print.full newEnv t)
 101         end
 102       | Some t' ->
 103         if t=t'
 104         then ()
 105         else
 106           begin
 107             lprintf (Bold Green) "#%d: " n;
 108             lprintf (Normal Green) "%s; " (Typing_print.full newEnv t')
 109           end
 110     ) newEnv.Env.tenv;
 111     IMap.iter (fun n _ ->
 112       if IMap.mem n newEnv.Env.tenv then ()
 113       else lprintf (Normal Red) "#%d deleted; " n) oldEnv.Env.tenv
 114   end)
 115
 116 (* Dump the diff between oldEnv and newEnv. TODO: lenv component *)
 117 let log_env_diff oldEnv newEnv =
 118   begin
 119     log_subst_diff oldEnv.Env.subst newEnv.Env.subst;
 120     log_tenv_diff oldEnv newEnv;
 121     lnewline ()
 122   end
 123
 124 let rec log_type_list env tyl =
 125   match tyl with
 126     | [] -> ()
 127     | [ty] ->
 128       lprintf (Normal Green) "%s" (Typing_print.debug env ty)
 129     | ty::tyl ->
 130       lprintf (Normal Green) "%s, " (Typing_print.debug env ty);
 131       log_type_list env tyl
 132
 133 let log_continuation env name cont =
 134   indentEnv (Typing_continuations.to_string name) (fun () ->
 135     Local_id.Map.iter begin fun id (type_, expr_id) ->
 136       lnewline();
 137       lprintf (Bold Green) "%s[#%d]: "
 138         (Local_id.get_name id) (Local_id.to_int id);
 139       lprintf (Normal Green) "%s" (Typing_print.debug env type_);
 140       lprintf (Normal Green) " [eid: %s]" (Ident.debug expr_id) end
 141     cont)
 142
 143 let log_local_types env =
 144   indentEnv "local_types" (fun () ->
 145     Typing_continuations.Map.iter
 146       (log_continuation env)
 147       env.Env.lenv.Env.local_types)
 148
 149 let log_using_vars env =
 150   let using_vars = env.Env.lenv.Env.local_using_vars in
 151   if not (Local_id.Set.is_empty using_vars) then
 152   indentEnv "using_vars" (fun () ->
 153     Local_id.Set.iter (fun lvar ->
 154       lprintf (Normal Green) "%s " (Local_id.get_name lvar))
 155       using_vars)
 156
 157 let log_return_type env =
 158   indentEnv "return_type" (fun () ->
 159     let Typing_env_return_info.
 160       {return_type; return_disposable; return_mutable; return_explicit;
 161        return_void_to_rx; } = Env.get_return env in
 162     lprintf (Normal Green) "%s%s%s%s%s"
 163       (Typing_print.debug env return_type)
 164       (if return_disposable then " (disposable)" else "")
 165       (if return_mutable then " (mutable_return)" else "")
 166       (if return_explicit then " (explicit)" else "")
 167       (if return_void_to_rx then " (void_to_rx)" else "")
 168   )
 169
 170 let log_tpenv env =
 171   let tparams = Env.get_generic_parameters env in
 172   if not (List.is_empty tparams) then
 173   indentEnv "tpenv" (fun () ->
 174     List.iter tparams ~f:begin fun tparam ->
 175       let lower = Typing_set.elements (Env.get_lower_bounds env tparam) in
 176       let upper = Typing_set.elements (Env.get_upper_bounds env tparam) in
 177       lnewline ();
 178       (if not (List.is_empty lower)
 179       then (log_type_list env lower; lprintf (Normal Green) " <: "));
 180       lprintf (Bold Green) "%s" tparam;
 181       (if not (List.is_empty upper)
 182       then (lprintf (Normal Green) " <: "; log_type_list env upper))
 183         end)
 184
 185 let log_tvenv env =
 186   indentEnv "tvenv" (fun () ->
 187     IMap.iter begin fun var
 188       Env.{ lower_bounds; upper_bounds;
 189         appears_covariantly; appears_contravariantly; _ } ->
 190       let lower = Typing_set.elements lower_bounds in
 191       let upper = Typing_set.elements upper_bounds in
 192       lnewline ();
 193       (if not (List.is_empty lower)
 194       then (log_type_list env lower; lprintf (Normal Green) " <: "));
 195       lprintf (Bold Green) "%s%s#%d"
 196         (if appears_covariantly then "+" else "")
 197         (if appears_contravariantly then "-" else "")
 198         var;
 199       (if not (List.is_empty upper)
 200       then (lprintf (Normal Green) " <: "; log_type_list env upper))
 201       end env.Env.tvenv)
 202
 203 let log_tyvars env =
 204   indentEnv "tyvars_stack" (fun () ->
 205     lprintf (Normal Green) "%s"
 206       (String.concat ~sep:"/" (List.map ~f:(fun vars -> "{" ^ String.concat ~sep:","
 207         (List.map ~f:(fun i -> Printf.sprintf "#%d" i) vars) ^ "}")
 208         env.Env.tyvars_stack)))
 209
 210 let log_fake_members env =
 211   let lenv = env.Env.lenv in
 212   let fakes = lenv.Env.fake_members in
 213   indentEnv "fake_members" (fun () ->
 214     (match fakes.Env.last_call with
 215     | None -> ()
 216     | Some p ->
 217       begin
 218         lprintf (Normal Green) "last_call: %s" (Pos.string (Pos.to_absolute p));
 219         lnewline ()
 220       end);
 221     lprintf (Normal Green) "invalid:";
 222     SSet.iter (lprintf (Normal Green) " %s") fakes.Env.invalid ;
 223     lnewline ();
 224     lprintf (Normal Green) "valid:";
 225     SSet.iter (lprintf (Normal Green) " %s") fakes.Env.valid;
 226     lnewline ())
 227
 228 let log_position p f =
 229   let n =
 230     match Pos.Map.get p !iterations with
 231     | None -> iterations := Pos.Map.add p 1 !iterations; 1
 232     | Some n -> iterations := Pos.Map.add p (n+1) !iterations; n+1 in
 233   (* If we've hit this many iterations then something must have gone wrong
 234    * so let's not bother spewing to the log *)
 235   if n > 10000 then ()
 236   else
 237     indentEnv (Pos.string (Pos.to_absolute p)
 238       ^ (if n = 1 then "" else "[" ^ string_of_int n ^ "]")) f
 239
 240 let log_subtype_prop ?(do_normalize = false) env message prop =
 241   lprintf (Tty.Bold Tty.Green) "%s: " message;
 242   lprintf (Tty.Normal Tty.Green) "%s"
 243     (Typing_print.subtype_prop ~do_normalize env prop);
 244   lnewline ()
 245
 246 (* Log the environment: local_types, subst, tenv and tpenv *)
 247 let hh_show_env p env =
 248   log_position p
 249     (fun () ->
 250        log_local_types env;
 251        log_using_vars env;
 252        log_fake_members env;
 253        log_return_type env;
 254        log_env_diff (!lastenv) env;
 255        log_tpenv env;
 256        log_tvenv env;
 257        log_tyvars env;
 258        log_subtype_prop env "subtype_prop" env.Env.subtype_prop);
 259   lastenv := env
 260
 261 (* Log the type of an expression *)
 262 let hh_show p env ty =
 263   let s1 = Typing_print.debug env ty in
 264   let s2_opt = Typing_print.constraints_for_type env ty in
 265   log_position p
 266     (fun () ->
 267        lprintf (Normal Green) "%s" s1;
 268        lnewline ();
 269        match s2_opt with
 270        | None -> ()
 271        | Some s2 -> (lprintf (Normal Green) "%s" s2; lnewline ()))
 272
 273
 274 (* Simple type of possible log data *)
 275 type log_structure =
 276 | Log_head of string * log_structure list
 277 | Log_type of string * Typing_defs.locl Typing_defs.ty
 278
 279 let log_with_level env key level log_f =
 280   if Env.get_log_level env key >= level then log_f ()
 281   else ()
 282
 283 let log_types p env items =
 284   log_position p
 285     (fun () ->
 286       let rec go items =
 287         List.iter items (fun item ->
 288           match item with
 289           | Log_head (message, items) ->
 290             indentEnv ~color:(Normal Yellow) message (fun () -> go items)
 291           | Log_type (message, ty) ->
 292             let s = Typing_print.debug env ty in
 293             lprintf (Bold Green) "%s: " message;
 294             lprintf (Normal Green) "%s" s;
 295             lnewline ()) in
 296       go items)
 297
 298 let log_prop ?(do_normalize = false) level p message env prop =
 299   log_with_level env "prop" level (fun () ->
 300     log_position p (fun () -> log_subtype_prop ~do_normalize env message prop))
 301
 302 let increment_feature_count env s =
 303   if GlobalOptions.tco_language_feature_logging (Env.get_tcopt env)
 304   then Measure.sample s 1.0