hphp/hack/src/typing/typing_print.ml

   1 (*
   2  * Copyright (c) 2015, 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 (*****************************************************************************)
  11 (* Pretty printing of types *)
  12 (*****************************************************************************)
  13
  14 open Hh_prelude
  15 open Typing_defs
  16 open Typing_env_types
  17 open Typing_logic
  18 module SN = Naming_special_names
  19 module Reason = Typing_reason
  20 module TySet = Typing_set
  21 module Cls = Decl_provider.Class
  22 module Nast = Aast
  23
  24 let strip_ns id = id |> Utils.strip_ns |> Hh_autoimport.reverse_type
  25
  26 let shallow_decl_enabled (ctx : Provider_context.t) : bool =
  27   TypecheckerOptions.shallow_class_decl (Provider_context.get_tcopt ctx)
  28
  29 (*****************************************************************************)
  30 (* Pretty-printer of the "full" type.                                        *)
  31 (* This is used in server/symbolTypeService and elsewhere                    *)
  32 (* With debug_mode set it is used for hh_show_env                            *)
  33 (*****************************************************************************)
  34
  35 module Full = struct
  36   module Env = Typing_env
  37   open Doc
  38
  39   let format_env = Format_env.{ default with line_width = 60 }
  40
  41   let text_strip_ns s = Doc.text (strip_ns s)
  42
  43   let ( ^^ ) a b = Concat [a; b]
  44
  45   let debug_mode = ref false
  46
  47   let show_verbose env = Env.get_log_level env "show" > 1
  48
  49   let blank_tyvars = ref false
  50
  51   let comma_sep = Concat [text ","; Space]
  52
  53   let id x = x
  54
  55   let list_sep ?(split = true) (s : Doc.t) (f : 'a -> Doc.t) (l : 'a list) :
  56       Doc.t =
  57     let split =
  58       if split then
  59         Split
  60       else
  61         Nothing
  62     in
  63     let max_idx = List.length l - 1 in
  64     let elements =
  65       List.mapi l ~f:(fun idx element ->
  66           if Int.equal idx max_idx then
  67             f element
  68           else
  69             Concat [f element; s; split])
  70     in
  71     match elements with
  72     | [] -> Nothing
  73     | xs -> Nest [split; Concat xs; split]
  74
  75   let delimited_list sep left_delimiter f l right_delimiter =
  76     Span
  77       [
  78         text left_delimiter;
  79         WithRule (Rule.Parental, Concat [list_sep sep f l; text right_delimiter]);
  80       ]
  81
  82   let list : type c. _ -> (c -> Doc.t) -> c list -> _ -> _ =
  83    (fun ld x y rd -> delimited_list comma_sep ld x y rd)
  84
  85   let shape_map fdm f_field =
  86     let compare (k1, _) (k2, _) =
  87       String.compare (Env.get_shape_field_name k1) (Env.get_shape_field_name k2)
  88     in
  89     let fields = List.sort ~compare (Nast.ShapeMap.bindings fdm) in
  90     List.map fields f_field
  91
  92   let rec fun_type ~ty to_doc st env ft =
  93     let params = List.map ft.ft_params (fun_param ~ty to_doc st env) in
  94     let variadic_param =
  95       match ft.ft_arity with
  96       | Fstandard -> None
  97       | Fvariadic p ->
  98         Some
  99           (Concat
 100              [
 101                (match ty to_doc st env p.fp_type.et_type with
 102                | Text ("_", 1) ->
 103                  (* Handle the case of missing a type by not printing it *)
 104                  Nothing
 105                | _ -> fun_param ~ty to_doc st env p);
 106                text "...";
 107              ])
 108     in
 109     let params =
 110       match variadic_param with
 111       | None -> params
 112       | Some variadic_param -> params @ [variadic_param]
 113     in
 114     Span
 115       [
 116         (* only print tparams when they have been instantiated with targs
 117          * so that they correctly express reified parameterization *)
 118         (match (ft.ft_tparams, get_ft_ftk ft) with
 119         | ([], _)
 120         | (_, FTKtparams) ->
 121           Nothing
 122         | (l, FTKinstantiated_targs) ->
 123           list "<" (tparam ~ty to_doc st env) l ">");
 124         list "(" id params "):";
 125         Space;
 126         possibly_enforced_ty ~ty to_doc st env ft.ft_ret;
 127       ]
 128
 129   and possibly_enforced_ty ~ty to_doc st env { et_enforced; et_type } =
 130     Concat
 131       [
 132         ( if show_verbose env && et_enforced then
 133           text "enforced" ^^ Space
 134         else
 135           Nothing );
 136         ty to_doc st env et_type;
 137       ]
 138
 139   and fun_param ~ty to_doc st env ({ fp_name; fp_type; _ } as fp) =
 140     Concat
 141       [
 142         (match get_fp_mode fp with
 143         | FPinout -> text "inout" ^^ Space
 144         | _ -> Nothing);
 145         (match (fp_name, ty to_doc st env fp_type.et_type) with
 146         | (None, _) -> possibly_enforced_ty ~ty to_doc st env fp_type
 147         | (Some param_name, Text ("_", 1)) ->
 148           (* Handle the case of missing a type by not printing it *)
 149           text param_name
 150         | (Some param_name, _) ->
 151           Concat
 152             [
 153               possibly_enforced_ty ~ty to_doc st env fp_type;
 154               Space;
 155               text param_name;
 156             ]);
 157         ( if get_fp_has_default fp then
 158           text "=_"
 159         else
 160           Nothing );
 161       ]
 162
 163   and tparam
 164       ~ty
 165       to_doc
 166       st
 167       env
 168       { tp_name = (_, x); tp_constraints = cstrl; tp_reified = r; _ } =
 169     Concat
 170       [
 171         begin
 172           match r with
 173           | Nast.Erased -> Nothing
 174           | Nast.SoftReified -> text "<<__Soft>> reify" ^^ Space
 175           | Nast.Reified -> text "reify" ^^ Space
 176         end;
 177         text x;
 178         list_sep ~split:false Space (tparam_constraint ~ty to_doc st env) cstrl;
 179       ]
 180
 181   and tparam_constraint ~ty to_doc st env (ck, cty) =
 182     Concat
 183       [
 184         Space;
 185         text
 186           (match ck with
 187           | Ast_defs.Constraint_as -> "as"
 188           | Ast_defs.Constraint_super -> "super"
 189           | Ast_defs.Constraint_eq -> "=");
 190         Space;
 191         ty to_doc st env cty;
 192       ]
 193
 194   let terr () =
 195     text
 196       ( if !debug_mode then
 197         "err"
 198       else
 199         "_" )
 200
 201   let tprim x =
 202     text
 203     @@
 204     match x with
 205     | Nast.Tnull -> "null"
 206     | Nast.Tvoid -> "void"
 207     | Nast.Tint -> "int"
 208     | Nast.Tbool -> "bool"
 209     | Nast.Tfloat -> "float"
 210     | Nast.Tstring -> "string"
 211     | Nast.Tnum -> "num"
 212     | Nast.Tresource -> "resource"
 213     | Nast.Tarraykey -> "arraykey"
 214     | Nast.Tnoreturn -> "noreturn"
 215
 216   let tdarray k x y = list "darray<" k [x; y] ">"
 217
 218   let tvarray k x = list "varray<" k [x] ">"
 219
 220   let tvarray_or_darray k x y = list "varray_or_darray<" k [x; y] ">"
 221
 222   let tarray k x y =
 223     match (x, y) with
 224     | (None, None) -> text "array"
 225     | (Some x, None) -> list "array<" k [x] ">"
 226     | (Some x, Some y) -> list "array<" k [x; y] ">"
 227     | (None, Some _) -> assert false
 228
 229   let tfun ~ty to_doc st env ft =
 230     Concat
 231       [
 232         text "(";
 233         ( if get_ft_is_coroutine ft then
 234           text "coroutine" ^^ Space
 235         else
 236           Nothing );
 237         text "function";
 238         fun_type ~ty to_doc st env ft;
 239         text ")";
 240       ]
 241
 242   let ttuple k tyl = list "(" k tyl ")"
 243
 244   let tshape k to_doc shape_kind fdm =
 245     let fields =
 246       let f_field (shape_map_key, { sft_optional; sft_ty }) =
 247         let key_delim =
 248           match shape_map_key with
 249           | Ast_defs.SFlit_str _ -> text "'"
 250           | _ -> Nothing
 251         in
 252         Concat
 253           [
 254             ( if sft_optional then
 255               text "?"
 256             else
 257               Nothing );
 258             key_delim;
 259             to_doc (Env.get_shape_field_name shape_map_key);
 260             key_delim;
 261             Space;
 262             text "=>";
 263             Space;
 264             k sft_ty;
 265           ]
 266       in
 267       shape_map fdm f_field
 268     in
 269     let fields =
 270       match shape_kind with
 271       | Closed_shape -> fields
 272       | Open_shape -> fields @ [text "..."]
 273     in
 274     list "shape(" id fields ")"
 275
 276   let thas_member k hm =
 277     let { hm_name = (_, name); hm_type; hm_class_id = _; hm_explicit_targs } =
 278       hm
 279     in
 280     (* TODO: T71614503 print explicit type arguments appropriately *)
 281     let printed_explicit_targs =
 282       match hm_explicit_targs with
 283       | None -> text "None"
 284       | Some _ -> text "Some <targs>"
 285     in
 286     Concat
 287       [
 288         text "has_member";
 289         text "(";
 290         text name;
 291         comma_sep;
 292         k hm_type;
 293         comma_sep;
 294         printed_explicit_targs;
 295         text ")";
 296       ]
 297
 298   let tdestructure k d =
 299     let { d_required; d_optional; d_variadic; d_kind } = d in
 300     let e_required = List.map d_required ~f:k in
 301     let e_optional =
 302       List.map d_optional ~f:(fun v -> Concat [text "=_"; k v])
 303     in
 304     let e_variadic =
 305       Option.value_map
 306         ~default:[]
 307         ~f:(fun v -> [Concat [text "..."; k v]])
 308         d_variadic
 309     in
 310     let prefix =
 311       match d_kind with
 312       | ListDestructure -> text "list"
 313       | SplatUnpack -> text "splat"
 314     in
 315     Concat [prefix; list "(" id (e_required @ e_optional @ e_variadic) ")"]
 316
 317   let rec decl_ty to_doc st env x = decl_ty_ to_doc st env (get_node x)
 318
 319   and decl_ty_ : _ -> _ -> _ -> decl_phase ty_ -> Doc.t =
 320    fun to_doc st env x ->
 321     let ty = decl_ty in
 322     let k x = ty to_doc st env x in
 323     match x with
 324     | Tany _ -> text "_"
 325     | Terr -> terr ()
 326     | Tthis -> text SN.Typehints.this
 327     | Tmixed -> text "mixed"
 328     | Tdynamic -> text "dynamic"
 329     | Tnonnull -> text "nonnull"
 330     | Tdarray (x, y) -> tdarray k x y
 331     | Tvarray x -> tvarray k x
 332     | Tvarray_or_darray (x, y) -> tvarray_or_darray k x y
 333     | Tarray (x, y) -> tarray k x y
 334     | Tapply ((_, s), []) -> to_doc s
 335     | Tgeneric (s, []) -> to_doc s
 336     | Taccess (root_ty, id) -> Concat [k root_ty; text "::"; to_doc (snd id)]
 337     | Toption x -> Concat [text "?"; k x]
 338     | Tlike x -> Concat [text "~"; k x]
 339     | Tprim x -> tprim x
 340     | Tvar x -> text (Printf.sprintf "#%d" x)
 341     | Tfun ft -> tfun ~ty to_doc st env ft
 342     (* Don't strip_ns here! We want the FULL type, including the initial slash.
 343       *)
 344     | Tapply ((_, s), tyl)
 345     | Tgeneric (s, tyl) ->
 346       to_doc s ^^ list "<" k tyl ">"
 347     | Ttuple tyl -> ttuple k tyl
 348     | Tunion tyl -> Concat [text "|"; ttuple k tyl]
 349     | Tintersection tyl -> Concat [text "&"; ttuple k tyl]
 350     | Tshape (shape_kind, fdm) -> tshape k to_doc shape_kind fdm
 351
 352   let rec locl_ty : _ -> _ -> _ -> locl_ty -> Doc.t =
 353    fun to_doc st env ty ->
 354     let (r, x) = deref ty in
 355     let d = locl_ty_ to_doc st env x in
 356     match r with
 357     | Typing_reason.Rsolve_fail _ -> Concat [text "{suggest:"; d; text "}"]
 358     | _ -> d
 359
 360   and locl_ty_ : _ -> _ -> _ -> locl_phase ty_ -> Doc.t =
 361    fun to_doc st env x ->
 362     let ty = locl_ty in
 363     let k x = ty to_doc st env x in
 364     match x with
 365     | Tany _ -> text "_"
 366     | Terr -> terr ()
 367     | Tdynamic -> text "dynamic"
 368     | Tnonnull -> text "nonnull"
 369     | Tvarray_or_darray (x, y) -> tvarray_or_darray k x y
 370     | Tvarray x -> tvarray k x
 371     | Tdarray (x, y) -> tdarray k x y
 372     | Tclass ((_, s), Exact, []) when !debug_mode ->
 373       Concat [text "exact"; Space; to_doc s]
 374     | Tclass ((_, s), _, []) -> to_doc s
 375     | Toption ty ->
 376       begin
 377         match deref ty with
 378         | (_, Tnonnull) -> text "mixed"
 379         | (r, Tunion tyl)
 380           when TypecheckerOptions.like_type_hints (Env.get_tcopt env)
 381                && List.exists ~f:is_dynamic tyl ->
 382           (* Unions with null become Toption, which leads to the awkward ?~...
 383            * The Tunion case can better handle this *)
 384           k (mk (r, Tunion (mk (r, Tprim Nast.Tnull) :: tyl)))
 385         | _ -> Concat [text "?"; k ty]
 386       end
 387     | Tprim x -> tprim x
 388     | Tvar n ->
 389       let (_, ety) = Env.expand_type env (mk (Reason.Rnone, Tvar n)) in
 390       begin
 391         match deref ety with
 392         (* For unsolved type variables, always show the type variable *)
 393         | (_, Tvar n') ->
 394           if ISet.mem n' st then
 395             text "[rec]"
 396           else if !blank_tyvars then
 397             text "[unresolved]"
 398           else
 399             text ("#" ^ string_of_int n')
 400         | _ ->
 401           let prepend =
 402             if ISet.mem n st then
 403               text "[rec]"
 404             else if
 405               (* For hh_show_env we further show the type variable number *)
 406               show_verbose env
 407             then
 408               text ("#" ^ string_of_int n)
 409             else
 410               Nothing
 411           in
 412           let st = ISet.add n st in
 413           Concat [prepend; ty to_doc st env ety]
 414       end
 415     | Tfun ft -> tfun ~ty to_doc st env ft
 416     | Tclass ((_, s), exact, tyl) ->
 417       let d = to_doc s ^^ list "<" k tyl ">" in
 418       begin
 419         match exact with
 420         | Exact when !debug_mode -> Concat [text "exact"; Space; d]
 421         | _ -> d
 422       end
 423     | Tunapplied_alias s
 424     | Tnewtype (s, [], _)
 425     | Tgeneric (s, []) ->
 426       to_doc s
 427     | Tnewtype (s, tyl, _)
 428     | Tgeneric (s, tyl) ->
 429       to_doc s ^^ list "<" k tyl ">"
 430     | Tdependent (dep, cstr) ->
 431       let cstr_info =
 432         if
 433           !debug_mode
 434           ||
 435           match dep with
 436           | DTexpr _ -> true
 437           | _ -> false
 438         then
 439           Concat [Space; text "as"; Space; k cstr]
 440         else
 441           Nothing
 442       in
 443       Concat [to_doc @@ DependentKind.to_string dep; cstr_info]
 444     (* Don't strip_ns here! We want the FULL type, including the initial slash.
 445       *)
 446     | Ttuple tyl -> ttuple k tyl
 447     | Tunion [] -> text "nothing"
 448     | Tunion tyl when TypecheckerOptions.like_type_hints (Env.get_tcopt env) ->
 449       let tyl =
 450         List.fold_right tyl ~init:Typing_set.empty ~f:Typing_set.add
 451         |> Typing_set.elements
 452       in
 453       let (dynamic, null, nonnull) =
 454         List.partition3_map tyl ~f:(fun t ->
 455             match get_node t with
 456             | Tdynamic -> `Fst t
 457             | Tprim Nast.Tnull -> `Snd t
 458             | _ -> `Trd t)
 459       in
 460       begin
 461         match
 462           (not @@ List.is_empty dynamic, not @@ List.is_empty null, nonnull)
 463         with
 464         | (false, false, []) -> text "nothing"
 465         (* type isn't nullable or dynamic *)
 466         | (false, false, [ty]) ->
 467           if show_verbose env then
 468             Concat [text "("; k ty; text ")"]
 469           else
 470             k ty
 471         | (false, false, _ :: _) ->
 472           delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")"
 473         (* Type only is null *)
 474         | (false, true, []) ->
 475           if show_verbose env then
 476             text "(null)"
 477           else
 478             text "null"
 479         (* Type only is dynamic *)
 480         | (true, false, []) ->
 481           if show_verbose env then
 482             text "(dynamic)"
 483           else
 484             text "dynamic"
 485         (* Type is nullable single type *)
 486         | (false, true, [ty]) ->
 487           if show_verbose env then
 488             Concat [text "(null |"; k ty; text ")"]
 489           else
 490             Concat [text "?"; k ty]
 491         (* Type is like single type *)
 492         | (true, false, [ty]) ->
 493           if show_verbose env then
 494             Concat [text "(dynamic |"; k ty; text ")"]
 495           else
 496             Concat [text "~"; k ty]
 497         (* Type is like null *)
 498         | (true, true, []) ->
 499           if show_verbose env then
 500             text "(dynamic | null)"
 501           else
 502             text "~null"
 503         (* Type is like nullable single type *)
 504         | (true, true, [ty]) ->
 505           if show_verbose env then
 506             Concat [text "(dynamic | null |"; k ty; text ")"]
 507           else
 508             Concat [text "~?"; k ty]
 509         | (true, false, _ :: _) ->
 510           Concat
 511             [
 512               text "~";
 513               delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")";
 514             ]
 515         | (false, true, _ :: _) ->
 516           Concat
 517             [
 518               text "?";
 519               delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")";
 520             ]
 521         | (true, true, _ :: _) ->
 522           Concat
 523             [
 524               text "~";
 525               text "?";
 526               delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")";
 527             ]
 528       end
 529     | Tunion tyl ->
 530       let tyl =
 531         List.fold_right tyl ~init:Typing_set.empty ~f:Typing_set.add
 532         |> Typing_set.elements
 533       in
 534       let (null, nonnull) =
 535         List.partition_tf tyl ~f:(fun ty ->
 536             equal_locl_ty_ (get_node ty) (Tprim Nast.Tnull))
 537       in
 538       begin
 539         match (null, nonnull) with
 540         (* type isn't nullable *)
 541         | ([], [ty]) ->
 542           if show_verbose env then
 543             Concat [text "("; k ty; text ")"]
 544           else
 545             k ty
 546         | ([], _) ->
 547           delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")"
 548         (* Type only is null *)
 549         | (_, []) ->
 550           if show_verbose env then
 551             text "(null)"
 552           else
 553             text "null"
 554         (* Type is nullable single type *)
 555         | (_, [ty]) ->
 556           if show_verbose env then
 557             Concat [text "(null |"; k ty; text ")"]
 558           else
 559             Concat [text "?"; k ty]
 560         (* Type is nullable union type *)
 561         | (_, _) ->
 562           Concat
 563             [
 564               text "?";
 565               delimited_list (Space ^^ text "|" ^^ Space) "(" k nonnull ")";
 566             ]
 567       end
 568     | Tintersection [] -> text "mixed"
 569     | Tintersection tyl ->
 570       delimited_list (Space ^^ text "&" ^^ Space) "(" k tyl ")"
 571     | Tobject -> text "object"
 572     | Tshape (shape_kind, fdm) -> tshape k to_doc shape_kind fdm
 573     | Taccess (root_ty, id) -> Concat [k root_ty; text "::"; to_doc (snd id)]
 574
 575   let rec constraint_type_ to_doc st env x =
 576     let k lty = locl_ty to_doc st env lty in
 577     let k' cty = constraint_type to_doc st env cty in
 578     match x with
 579     | Thas_member hm -> thas_member k hm
 580     | Tdestructure d -> tdestructure k d
 581     | TCunion (lty, cty) -> Concat [text "("; k lty; text "|"; k' cty; text ")"]
 582     | TCintersection (lty, cty) ->
 583       Concat [text "("; k lty; text "&"; k' cty; text ")"]
 584
 585   and constraint_type to_doc st env ty =
 586     let (r, x) = deref_constraint_type ty in
 587     let d = constraint_type_ to_doc st env x in
 588     match r with
 589     | Typing_reason.Rsolve_fail _ -> Concat [text "{suggest:"; d; text "}"]
 590     | _ -> d
 591
 592   let internal_type to_doc st env ty =
 593     match ty with
 594     | LoclType ty -> locl_ty to_doc st env ty
 595     | ConstraintType ty -> constraint_type to_doc st env ty
 596
 597   (* For a given type parameter, construct a list of its constraints *)
 598   let get_constraints_on_tparam env tparam =
 599     let kind_opt = Env.get_pos_and_kind_of_generic env tparam in
 600     match kind_opt with
 601     | None -> []
 602     | Some (_pos, kind) ->
 603       (* Use the names of the parameters themselves to present bounds
 604          depending on other parameters *)
 605       let param_names = Type_parameter_env.get_parameter_names kind in
 606       let params =
 607         List.map param_names (fun name ->
 608             Typing_make_type.generic Reason.none name)
 609       in
 610       let lower = Env.get_lower_bounds env tparam params in
 611       let upper = Env.get_upper_bounds env tparam params in
 612       let equ = Env.get_equal_bounds env tparam params in
 613       (* If we have an equality we can ignore the other bounds *)
 614       if not (TySet.is_empty equ) then
 615         List.map (TySet.elements equ) (fun ty ->
 616             (tparam, Ast_defs.Constraint_eq, ty))
 617       else
 618         List.map (TySet.elements lower) (fun ty ->
 619             (tparam, Ast_defs.Constraint_super, ty))
 620         @ List.map (TySet.elements upper) (fun ty ->
 621               (tparam, Ast_defs.Constraint_as, ty))
 622
 623   let to_string ~ty to_doc env x =
 624     ty to_doc ISet.empty env x
 625     |> Libhackfmt.format_doc_unbroken format_env
 626     |> String.strip
 627
 628   let constraints_for_type to_doc env typ =
 629     let tparams = SSet.elements (Env.get_tparams env typ) in
 630     let constraints = List.concat_map tparams (get_constraints_on_tparam env) in
 631     if List.is_empty constraints then
 632       None
 633     else
 634       Some
 635         (Concat
 636            [
 637              text "where";
 638              Space;
 639              WithRule
 640                ( Rule.Parental,
 641                  list_sep
 642                    comma_sep
 643                    begin
 644                      fun (tparam, ck, typ) ->
 645                      Concat
 646                        [
 647                          text tparam;
 648                          tparam_constraint
 649                            ~ty:locl_ty
 650                            to_doc
 651                            ISet.empty
 652                            env
 653                            (ck, typ);
 654                        ]
 655                    end
 656                    constraints );
 657            ])
 658
 659   let to_string_rec env n x =
 660     locl_ty Doc.text (ISet.add n ISet.empty) env x
 661     |> Libhackfmt.format_doc_unbroken format_env
 662     |> String.strip
 663
 664   let to_string_strip_ns ~ty env x = to_string ~ty text_strip_ns env x
 665
 666   let to_string_decl ctx (x : decl_ty) =
 667     let ty = decl_ty in
 668     let env = Typing_env.empty ctx Relative_path.default ~droot:None in
 669     to_string ~ty Doc.text env x
 670
 671   let fun_to_string ctx (x : decl_fun_type) =
 672     let ty = decl_ty in
 673     let env = Typing_env.empty ctx Relative_path.default ~droot:None in
 674     fun_type ~ty Doc.text ISet.empty env x
 675     |> Libhackfmt.format_doc_unbroken format_env
 676     |> String.strip
 677
 678   let to_string_with_identity env x occurrence definition_opt =
 679     let ty = locl_ty in
 680     let prefix =
 681       SymbolDefinition.(
 682         let print_mod m = text (string_of_modifier m) ^^ Space in
 683         match definition_opt with
 684         | None -> Nothing
 685         | Some def ->
 686           begin
 687             match def.modifiers with
 688             | [] -> Nothing
 689             (* It looks weird if we line break after a single modifier. *)
 690             | [m] -> print_mod m
 691             | ms -> Concat (List.map ms print_mod) ^^ SplitWith Cost.Base
 692           end)
 693     in
 694     let body =
 695       SymbolOccurrence.(
 696         match (occurrence, get_node x) with
 697         | ({ type_ = Class; name; _ }, _) ->
 698           Concat [text "class"; Space; text_strip_ns name]
 699         | ({ type_ = Function; name; _ }, Tfun ft)
 700         | ({ type_ = Method (_, name); _ }, Tfun ft) ->
 701           (* Use short names for function types since they display a lot more
 702            information to the user. *)
 703           Concat
 704             [
 705               text "function";
 706               Space;
 707               text_strip_ns name;
 708               fun_type ~ty text_strip_ns ISet.empty env ft;
 709             ]
 710         | ({ type_ = Property _; name; _ }, _)
 711         | ({ type_ = ClassConst _; name; _ }, _)
 712         | ({ type_ = GConst; name; _ }, _) ->
 713           Concat [ty text_strip_ns ISet.empty env x; Space; text_strip_ns name]
 714         | _ -> ty text_strip_ns ISet.empty env x)
 715     in
 716     let constraints =
 717       constraints_for_type text_strip_ns env x
 718       |> Option.value_map ~default:Nothing ~f:(fun x -> Concat [Newline; x])
 719     in
 720     Concat [prefix; body; constraints]
 721     |> Libhackfmt.format_doc format_env
 722     |> String.strip
 723 end
 724
 725 let with_blank_tyvars f =
 726   Full.blank_tyvars := true;
 727   let res = f () in
 728   Full.blank_tyvars := false;
 729   res
 730
 731 (*****************************************************************************)
 732 (* Computes the string representing a type in an error message.
 733  *)
 734 (*****************************************************************************)
 735
 736 module ErrorString = struct
 737   module Env = Typing_env
 738
 739   let tprim = function
 740     | Nast.Tnull -> "null"
 741     | Nast.Tvoid -> "void"
 742     | Nast.Tint -> "an int"
 743     | Nast.Tbool -> "a bool"
 744     | Nast.Tfloat -> "a float"
 745     | Nast.Tstring -> "a string"
 746     | Nast.Tnum -> "a num (int | float)"
 747     | Nast.Tresource -> "a resource"
 748     | Nast.Tarraykey -> "an array key (int | string)"
 749     | Nast.Tnoreturn -> "noreturn (throws or exits)"
 750
 751   let varray = "a varray"
 752
 753   let darray = "a darray"
 754
 755   let varray_or_darray = "a varray_or_darray"
 756
 757   let rec type_ ?(ignore_dynamic = false) env ty =
 758     match ty with
 759     | Tany _ -> "an untyped value"
 760     | Terr -> "a type error"
 761     | Tdynamic -> "a dynamic value"
 762     | Tunion l when ignore_dynamic ->
 763       union env (List.filter l ~f:(fun x -> not (is_dynamic x)))
 764     | Tunion l -> union env l
 765     | Tintersection [] -> "a mixed value"
 766     | Tintersection l -> intersection env l
 767     | Tvarray_or_darray _ -> varray_or_darray
 768     | Tvarray _ -> varray
 769     | Tdarray (_, _) -> darray
 770     | Ttuple l -> "a tuple of size " ^ string_of_int (List.length l)
 771     | Tnonnull -> "a nonnull value"
 772     | Toption x ->
 773       begin
 774         match get_node x with
 775         | Tnonnull -> "a mixed value"
 776         | _ -> "a nullable type"
 777       end
 778     | Tprim tp -> tprim tp
 779     | Tvar _ -> "some value"
 780     | Tfun _ -> "a function"
 781     | Tgeneric (s, tyl) when DependentKind.is_generic_dep_ty s ->
 782       "the expression dependent type " ^ s ^ inst env tyl
 783     | Tgeneric (x, tyl) -> "a value of generic type " ^ x ^ inst env tyl
 784     | Tnewtype (x, _, _) when String.equal x SN.Classes.cClassname ->
 785       "a classname string"
 786     | Tnewtype (x, _, _) when String.equal x SN.Classes.cTypename ->
 787       "a typename string"
 788     | Tnewtype (x, tyl, _) -> "a value of type " ^ strip_ns x ^ inst env tyl
 789     | Tdependent (dep, _cstr) -> dependent dep
 790     | Tclass ((_, x), Exact, tyl) ->
 791       "an object of exactly the class " ^ strip_ns x ^ inst env tyl
 792     | Tclass ((_, x), Nonexact, tyl) ->
 793       "an object of type " ^ strip_ns x ^ inst env tyl
 794     | Tobject -> "an object"
 795     | Tshape _ -> "a shape"
 796     | Tunapplied_alias _ ->
 797       (* FIXME it seems like this function is only for
 798          fully-applied types? Tunapplied_alias should only appear
 799          in a type argument position then, which inst below
 800          prints with a different function (namely Full.locl_ty)  *)
 801       failwith "Tunapplied_alias is not a type"
 802     | Taccess (_ty, _id) -> "a type constant"
 803
 804   and inst env tyl =
 805     if List.is_empty tyl then
 806       ""
 807     else
 808       with_blank_tyvars (fun () ->
 809           "<"
 810           ^ String.concat
 811               ~sep:", "
 812               (List.map tyl ~f:(Full.to_string_strip_ns ~ty:Full.locl_ty env))
 813           ^ ">")
 814
 815   and dependent dep =
 816     let x = strip_ns @@ DependentKind.to_string dep in
 817     match dep with
 818     | DTthis
 819     | DTexpr _ ->
 820       "the expression dependent type " ^ x
 821
 822   and union env l =
 823     let (null, nonnull) =
 824       List.partition_tf l (fun ty ->
 825           equal_locl_ty_ (get_node ty) (Tprim Nast.Tnull))
 826     in
 827     let l = List.map nonnull (to_string env) in
 828     let s = List.fold_right l ~f:SSet.add ~init:SSet.empty in
 829     let l = SSet.elements s in
 830     if List.is_empty null then
 831       union_ l
 832     else
 833       "a nullable type"
 834
 835   and union_ = function
 836     | [] -> "an undefined value"
 837     | [x] -> x
 838     | x :: rl -> x ^ " or " ^ union_ rl
 839
 840   and intersection env l =
 841     let l = List.map l ~f:(to_string env) in
 842     String.concat l ~sep:" and "
 843
 844   and class_kind c_kind final =
 845     let fs =
 846       if final then
 847         " final"
 848       else
 849         ""
 850     in
 851     match c_kind with
 852     | Ast_defs.Cabstract -> "an abstract" ^ fs ^ " class"
 853     | Ast_defs.Cnormal -> "a" ^ fs ^ " class"
 854     | Ast_defs.Cinterface -> "an interface"
 855     | Ast_defs.Ctrait -> "a trait"
 856     | Ast_defs.Cenum -> "an enum"
 857
 858   and to_string ?(ignore_dynamic = false) env ty =
 859     let (_, ety) = Env.expand_type env ty in
 860     type_ ~ignore_dynamic env (get_node ety)
 861 end
 862
 863 module Json = struct
 864   open Hh_json
 865
 866   let prim = function
 867     | Nast.Tnull -> "null"
 868     | Nast.Tvoid -> "void"
 869     | Nast.Tint -> "int"
 870     | Nast.Tbool -> "bool"
 871     | Nast.Tfloat -> "float"
 872     | Nast.Tstring -> "string"
 873     | Nast.Tnum -> "num"
 874     | Nast.Tresource -> "resource"
 875     | Nast.Tarraykey -> "arraykey"
 876     | Nast.Tnoreturn -> "noreturn"
 877
 878   let param_mode_to_string = function
 879     | FPnormal -> "normal"
 880     | FPinout -> "inout"
 881
 882   let string_to_param_mode = function
 883     | "normal" -> Some FPnormal
 884     | "inout" -> Some FPinout
 885     | _ -> None
 886
 887   let rec from_type : env -> locl_ty -> json =
 888    fun env ty ->
 889     (* Helpers to construct fields that appear in JSON rendering of type *)
 890     let kind p k =
 891       [("src_pos", Pos.json (Pos.to_absolute p)); ("kind", JSON_String k)]
 892     in
 893     let args tys = [("args", JSON_Array (List.map tys (from_type env)))] in
 894     let typ ty = [("type", from_type env ty)] in
 895     let result ty = [("result", from_type env ty)] in
 896     let obj x = JSON_Object x in
 897     let name x = [("name", JSON_String x)] in
 898     let optional x = [("optional", JSON_Bool x)] in
 899     let is_array x = [("is_array", JSON_Bool x)] in
 900     let make_field (k, v) =
 901       let shape_field_name_to_json shape_field =
 902         (* TODO: need to update userland tooling? *)
 903         match shape_field with
 904         | Ast_defs.SFlit_int (_, s) -> Hh_json.JSON_Number s
 905         | Ast_defs.SFlit_str (_, s) -> Hh_json.JSON_String s
 906         | Ast_defs.SFclass_const ((_, s1), (_, s2)) ->
 907           Hh_json.JSON_Array [Hh_json.JSON_String s1; Hh_json.JSON_String s2]
 908       in
 909       obj
 910       @@ [("name", shape_field_name_to_json k)]
 911       @ optional v.sft_optional
 912       @ typ v.sft_ty
 913     in
 914     let fields fl = [("fields", JSON_Array (List.map fl make_field))] in
 915     let as_type ty = [("as", from_type env ty)] in
 916     match (get_pos ty, get_node ty) with
 917     | (_, Tvar n) ->
 918       let (_, ty) = Typing_env.expand_type env (mk (get_reason ty, Tvar n)) in
 919       begin
 920         match (get_pos ty, get_node ty) with
 921         | (p, Tvar _) -> obj @@ kind p "var"
 922         | _ -> from_type env ty
 923       end
 924     | (p, Ttuple tys) -> obj @@ kind p "tuple" @ is_array false @ args tys
 925     | (p, Tany _)
 926     | (p, Terr) ->
 927       obj @@ kind p "any"
 928     | (p, Tnonnull) -> obj @@ kind p "nonnull"
 929     | (p, Tdynamic) -> obj @@ kind p "dynamic"
 930     | (p, Tgeneric (s, tyargs)) ->
 931       obj @@ kind p "generic" @ is_array true @ name s @ args tyargs
 932     | (p, Tunapplied_alias s) -> obj @@ kind p "unapplied_alias" @ name s
 933     | (p, Tnewtype (s, _, ty)) when Typing_env.is_enum env s ->
 934       obj @@ kind p "enum" @ name s @ as_type ty
 935     | (p, Tnewtype (s, tys, ty)) ->
 936       obj @@ kind p "newtype" @ name s @ args tys @ as_type ty
 937     | (p, Tdependent (DTexpr _, ty)) ->
 938       obj
 939       @@ kind p "path"
 940       @ [("type", obj @@ kind (get_pos ty) "expr")]
 941       @ as_type ty
 942     | (p, Tdependent (DTthis, ty)) ->
 943       obj
 944       @@ kind p "path"
 945       @ [("type", obj @@ kind (get_pos ty) "this")]
 946       @ as_type ty
 947     | (p, Toption ty) ->
 948       begin
 949         match get_node ty with
 950         | Tnonnull -> obj @@ kind p "mixed"
 951         | _ -> obj @@ kind p "nullable" @ args [ty]
 952       end
 953     | (p, Tprim tp) -> obj @@ kind p "primitive" @ name (prim tp)
 954     | (p, Tclass ((_, cid), _, tys)) ->
 955       obj @@ kind p "class" @ name cid @ args tys
 956     | (p, Tobject) -> obj @@ kind p "object"
 957     | (p, Tshape (shape_kind, fl)) ->
 958       let fields_known =
 959         match shape_kind with
 960         | Closed_shape -> true
 961         | Open_shape -> false
 962       in
 963       obj
 964       @@ kind p "shape"
 965       @ is_array false
 966       @ [("fields_known", JSON_Bool fields_known)]
 967       @ fields (Nast.ShapeMap.bindings fl)
 968     | (p, Tunion []) -> obj @@ kind p "nothing"
 969     | (_, Tunion [ty]) -> from_type env ty
 970     | (p, Tunion tyl) -> obj @@ kind p "union" @ args tyl
 971     | (p, Tintersection []) -> obj @@ kind p "mixed"
 972     | (_, Tintersection [ty]) -> from_type env ty
 973     | (p, Tintersection tyl) -> obj @@ kind p "intersection" @ args tyl
 974     | (p, Tfun ft) ->
 975       let fun_kind p =
 976         if get_ft_is_coroutine ft then
 977           kind p "coroutine"
 978         else
 979           kind p "function"
 980       in
 981       let callconv cc =
 982         [("callConvention", JSON_String (param_mode_to_string cc))]
 983       in
 984       let param fp =
 985         obj @@ callconv (get_fp_mode fp) @ typ fp.fp_type.et_type
 986       in
 987       let params fps = [("params", JSON_Array (List.map fps param))] in
 988       obj @@ fun_kind p @ params ft.ft_params @ result ft.ft_ret.et_type
 989     | (p, Tvarray_or_darray (ty1, ty2)) ->
 990       obj @@ kind p "varray_or_darray" @ args [ty1; ty2]
 991     | (p, Tdarray (ty1, ty2)) -> obj @@ kind p "darray" @ args [ty1; ty2]
 992     | (p, Tvarray ty) -> obj @@ kind p "varray" @ args [ty]
 993     (* TODO akenn *)
 994     | (p, Taccess (ty, _id)) -> obj @@ kind p "type_constant" @ args [ty]
 995
 996   type deserialized_result = (locl_ty, deserialization_error) result
 997
 998   let wrap_json_accessor f x =
 999     match f x with
1000     | Ok value -> Ok value
1001     | Error access_failure ->
1002       Error
1003         (Deserialization_error
1004            (Hh_json.Access.access_failure_to_string access_failure))
1005
1006   let get_string x = wrap_json_accessor (Hh_json.Access.get_string x)
1007
1008   let get_bool x = wrap_json_accessor (Hh_json.Access.get_bool x)
1009
1010   let get_array x = wrap_json_accessor (Hh_json.Access.get_array x)
1011
1012   let get_val x = wrap_json_accessor (Hh_json.Access.get_val x)
1013
1014   let get_obj x = wrap_json_accessor (Hh_json.Access.get_obj x)
1015
1016   let deserialization_error ~message ~keytrace =
1017     Error
1018       (Deserialization_error
1019          (message ^ Hh_json.Access.keytrace_to_string keytrace))
1020
1021   let not_supported ~message ~keytrace =
1022     Error (Not_supported (message ^ Hh_json.Access.keytrace_to_string keytrace))
1023
1024   let wrong_phase ~message ~keytrace =
1025     Error (Wrong_phase (message ^ Hh_json.Access.keytrace_to_string keytrace))
1026
1027   (* TODO(T36532263) add PU stuff in here *)
1028   let to_locl_ty
1029       ?(keytrace = []) (ctx : Provider_context.t) (json : Hh_json.json) :
1030       deserialized_result =
1031     let reason = Reason.none in
1032     let ty (ty : locl_phase ty_) : deserialized_result = Ok (mk (reason, ty)) in
1033     let rec aux (json : Hh_json.json) ~(keytrace : Hh_json.Access.keytrace) :
1034         deserialized_result =
1035       Result.Monad_infix.(
1036         get_string "kind" (json, keytrace) >>= fun (kind, kind_keytrace) ->
1037         match kind with
1038         | "this" ->
1039           not_supported ~message:"Cannot deserialize 'this' type." ~keytrace
1040         | "any" -> ty (Typing_defs.make_tany ())
1041         | "mixed" -> ty (Toption (mk (reason, Tnonnull)))
1042         | "nonnull" -> ty Tnonnull
1043         | "dynamic" -> ty Tdynamic
1044         | "generic" ->
1045           get_string "name" (json, keytrace) >>= fun (name, _name_keytrace) ->
1046           get_bool "is_array" (json, keytrace)
1047           >>= fun (is_array, _is_array_keytrace) ->
1048           get_array "args" (json, keytrace) >>= fun (args, args_keytrace) ->
1049           aux_args args ~keytrace:args_keytrace >>= fun args ->
1050           if is_array then
1051             ty (Tgeneric (name, args))
1052           else
1053             wrong_phase ~message:"Tgeneric is a decl-phase type." ~keytrace
1054         | "enum" ->
1055           get_string "name" (json, keytrace) >>= fun (name, _name_keytrace) ->
1056           aux_as json ~keytrace >>= fun as_ty -> ty (Tnewtype (name, [], as_ty))
1057         | "unapplied_alias" ->
1058           get_string "name" (json, keytrace) >>= fun (name, name_keytrace) ->
1059           begin
1060             match Decl_provider.get_typedef ctx name with
1061             | Some _typedef -> ty (Tunapplied_alias name)
1062             | None ->
1063               deserialization_error
1064                 ~message:("Unknown type alias: " ^ name)
1065                 ~keytrace:name_keytrace
1066           end
1067         | "newtype" ->
1068           get_string "name" (json, keytrace) >>= fun (name, name_keytrace) ->
1069           begin
1070             match Decl_provider.get_typedef ctx name with
1071             | Some _typedef ->
1072               (* We end up only needing the name of the typedef. *)
1073               Ok name
1074             | None ->
1075               if String.equal name "HackSuggest" then
1076                 not_supported
1077                   ~message:"HackSuggest types for lambdas are not supported"
1078                   ~keytrace
1079               else
1080                 deserialization_error
1081                   ~message:("Unknown newtype: " ^ name)
1082                   ~keytrace:name_keytrace
1083           end
1084           >>= fun typedef_name ->
1085           get_array "args" (json, keytrace) >>= fun (args, args_keytrace) ->
1086           aux_args args ~keytrace:args_keytrace >>= fun args ->
1087           aux_as json ~keytrace >>= fun as_ty ->
1088           ty (Tnewtype (typedef_name, args, as_ty))
1089         | "path" ->
1090           get_obj "type" (json, keytrace) >>= fun (type_json, type_keytrace) ->
1091           get_string "kind" (type_json, type_keytrace)
1092           >>= fun (path_kind, path_kind_keytrace) ->
1093           get_array "path" (json, keytrace) >>= fun (ids_array, ids_keytrace) ->
1094           let ids =
1095             map_array
1096               ids_array
1097               ~keytrace:ids_keytrace
1098               ~f:(fun id_str ~keytrace ->
1099                 match id_str with
1100                 | JSON_String id -> Ok id
1101                 | _ ->
1102                   deserialization_error ~message:"Expected a string" ~keytrace)
1103           in
1104           ids >>= fun _ids ->
1105           begin
1106             match path_kind with
1107             | "expr" ->
1108               not_supported
1109                 ~message:
1110                   "Cannot deserialize path-dependent type involving an expression"
1111                 ~keytrace
1112             | "this" ->
1113               aux_as json ~keytrace >>= fun as_ty ->
1114               ty (Tdependent (DTthis, as_ty))
1115             | path_kind ->
1116               deserialization_error
1117                 ~message:("Unknown path kind: " ^ path_kind)
1118                 ~keytrace:path_kind_keytrace
1119           end
1120         | "darray" ->
1121           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1122           begin
1123             match args with
1124             | [ty1; ty2] ->
1125               aux ty1 ~keytrace:("0" :: keytrace) >>= fun ty1 ->
1126               aux ty2 ~keytrace:("1" :: keytrace) >>= fun ty2 ->
1127               ty (Tdarray (ty1, ty2))
1128             | _ ->
1129               deserialization_error
1130                 ~message:
1131                   (Printf.sprintf
1132                      "Invalid number of type arguments to darray (expected 2): %d"
1133                      (List.length args))
1134                 ~keytrace
1135           end
1136         | "varray" ->
1137           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1138           begin
1139             match args with
1140             | [ty1] ->
1141               aux ty1 ~keytrace:("0" :: keytrace) >>= fun ty1 ->
1142               ty (Tvarray ty1)
1143             | _ ->
1144               deserialization_error
1145                 ~message:
1146                   (Printf.sprintf
1147                      "Invalid number of type arguments to varray (expected 1): %d"
1148                      (List.length args))
1149                 ~keytrace
1150           end
1151         | "varray_or_darray" ->
1152           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1153           begin
1154             match args with
1155             | [ty1; ty2] ->
1156               aux ty1 ~keytrace:("0" :: keytrace) >>= fun ty1 ->
1157               aux ty2 ~keytrace:("1" :: keytrace) >>= fun ty2 ->
1158               ty (Tvarray_or_darray (ty1, ty2))
1159             | _ ->
1160               deserialization_error
1161                 ~message:
1162                   (Printf.sprintf
1163                      "Invalid number of type arguments to varray_or_darray (expected 2): %d"
1164                      (List.length args))
1165                 ~keytrace
1166           end
1167         | "array" ->
1168           get_array "args" (json, keytrace) >>= fun (args, _args_keytrace) ->
1169           begin
1170             match args with
1171             | [] ->
1172               let tany = mk (Reason.Rnone, Typing_defs.make_tany ()) in
1173               ty (Tvarray_or_darray (tany, tany))
1174             | [ty1] ->
1175               aux ty1 ~keytrace:("0" :: keytrace) >>= fun ty1 ->
1176               ty (Tvarray ty1)
1177             | [ty1; ty2] ->
1178               aux ty1 ~keytrace:("0" :: keytrace) >>= fun ty1 ->
1179               aux ty2 ~keytrace:("1" :: keytrace) >>= fun ty2 ->
1180               ty (Tdarray (ty1, ty2))
1181             | _ ->
1182               deserialization_error
1183                 ~message:
1184                   (Printf.sprintf
1185                      "Invalid number of type arguments to array (expected 0-2): %d"
1186                      (List.length args))
1187                 ~keytrace
1188           end
1189         | "tuple" ->
1190           get_array "args" (json, keytrace) >>= fun (args, args_keytrace) ->
1191           aux_args args ~keytrace:args_keytrace >>= fun args -> ty (Ttuple args)
1192         | "nullable" ->
1193           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1194           begin
1195             match args with
1196             | [nullable_ty] ->
1197               aux nullable_ty ~keytrace:("0" :: keytrace) >>= fun nullable_ty ->
1198               ty (Toption nullable_ty)
1199             | _ ->
1200               deserialization_error
1201                 ~message:
1202                   (Printf.sprintf
1203                      "Unsupported number of args for nullable type: %d"
1204                      (List.length args))
1205                 ~keytrace
1206           end
1207         | "primitive" ->
1208           get_string "name" (json, keytrace) >>= fun (name, keytrace) ->
1209           begin
1210             match name with
1211             | "void" -> Ok Nast.Tvoid
1212             | "int" -> Ok Nast.Tint
1213             | "bool" -> Ok Nast.Tbool
1214             | "float" -> Ok Nast.Tfloat
1215             | "string" -> Ok Nast.Tstring
1216             | "resource" -> Ok Nast.Tresource
1217             | "num" -> Ok Nast.Tnum
1218             | "arraykey" -> Ok Nast.Tarraykey
1219             | "noreturn" -> Ok Nast.Tnoreturn
1220             | _ ->
1221               deserialization_error
1222                 ~message:("Unknown primitive type: " ^ name)
1223                 ~keytrace
1224           end
1225           >>= fun prim_ty -> ty (Tprim prim_ty)
1226         | "class" ->
1227           get_string "name" (json, keytrace) >>= fun (name, _name_keytrace) ->
1228           let class_pos =
1229             match Decl_provider.get_class ctx name with
1230             | Some class_ty -> Cls.pos class_ty
1231             | None ->
1232               (* Class may not exist (such as in non-strict modes). *)
1233               Pos.none
1234           in
1235           get_array "args" (json, keytrace) >>= fun (args, _args_keytrace) ->
1236           aux_args args ~keytrace >>= fun tyl ->
1237           (* NB: "class" could have come from either a `Tapply` or a `Tclass`. Right
1238       now, we always return a `Tclass`. *)
1239           ty (Tclass ((class_pos, name), Nonexact, tyl))
1240         | "object" -> ty Tobject
1241         | "shape" ->
1242           get_array "fields" (json, keytrace)
1243           >>= fun (fields, fields_keytrace) ->
1244           get_bool "is_array" (json, keytrace)
1245           >>= fun (is_array, _is_array_keytrace) ->
1246           let unserialize_field field_json ~keytrace :
1247               ( Ast_defs.shape_field_name
1248                 * locl_phase Typing_defs.shape_field_type,
1249                 deserialization_error )
1250               result =
1251             get_val "name" (field_json, keytrace)
1252             >>= fun (name, name_keytrace) ->
1253             (* We don't need position information for shape field names. They're
1254         only used for error messages and the like. *)
1255             let dummy_pos = Pos.none in
1256             begin
1257               match name with
1258               | Hh_json.JSON_Number name ->
1259                 Ok (Ast_defs.SFlit_int (dummy_pos, name))
1260               | Hh_json.JSON_String name ->
1261                 Ok (Ast_defs.SFlit_str (dummy_pos, name))
1262               | Hh_json.JSON_Array
1263                   [Hh_json.JSON_String name1; Hh_json.JSON_String name2] ->
1264                 Ok
1265                   (Ast_defs.SFclass_const
1266                      ((dummy_pos, name1), (dummy_pos, name2)))
1267               | _ ->
1268                 deserialization_error
1269                   ~message:"Unexpected format for shape field name"
1270                   ~keytrace:name_keytrace
1271             end
1272             >>= fun shape_field_name ->
1273             (* Optional field may be absent for shape-like arrays. *)
1274             begin
1275               match get_val "optional" (field_json, keytrace) with
1276               | Ok _ ->
1277                 get_bool "optional" (field_json, keytrace)
1278                 >>| fun (optional, _optional_keytrace) -> optional
1279               | Error _ -> Ok false
1280             end
1281             >>= fun optional ->
1282             get_obj "type" (field_json, keytrace)
1283             >>= fun (shape_type, shape_type_keytrace) ->
1284             aux shape_type ~keytrace:shape_type_keytrace
1285             >>= fun shape_field_type ->
1286             let shape_field_type =
1287               { sft_optional = optional; sft_ty = shape_field_type }
1288             in
1289             Ok (shape_field_name, shape_field_type)
1290           in
1291           map_array fields ~keytrace:fields_keytrace ~f:unserialize_field
1292           >>= fun fields ->
1293           if is_array then
1294             (* We don't have enough information to perfectly reconstruct shape-like
1295         arrays. We're missing the keys in the shape map of the shape fields. *)
1296             not_supported
1297               ~message:"Cannot deserialize shape-like array type"
1298               ~keytrace
1299           else
1300             get_bool "fields_known" (json, keytrace)
1301             >>= fun (fields_known, _fields_known_keytrace) ->
1302             let shape_kind =
1303               if fields_known then
1304                 Closed_shape
1305               else
1306                 Open_shape
1307             in
1308             let fields =
1309               List.fold
1310                 fields
1311                 ~init:Nast.ShapeMap.empty
1312                 ~f:(fun shape_map (k, v) -> Nast.ShapeMap.add k v shape_map)
1313             in
1314             ty (Tshape (shape_kind, fields))
1315         | "union" ->
1316           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1317           aux_args args ~keytrace >>= fun tyl -> ty (Tunion tyl)
1318         | "intersection" ->
1319           get_array "args" (json, keytrace) >>= fun (args, keytrace) ->
1320           aux_args args ~keytrace >>= fun tyl -> ty (Tintersection tyl)
1321         | ("function" | "coroutine") as kind ->
1322           let _ft_is_coroutine = String.equal kind "coroutine" in
1323           get_array "params" (json, keytrace)
1324           >>= fun (params, params_keytrace) ->
1325           let params =
1326             map_array
1327               params
1328               ~keytrace:params_keytrace
1329               ~f:(fun param ~keytrace ->
1330                 get_string "callConvention" (param, keytrace)
1331                 >>= fun (callconv, callconv_keytrace) ->
1332                 begin
1333                   match string_to_param_mode callconv with
1334                   | Some callconv -> Ok callconv
1335                   | None ->
1336                     deserialization_error
1337                       ~message:("Unknown calling convention: " ^ callconv)
1338                       ~keytrace:callconv_keytrace
1339                 end
1340                 >>= fun callconv ->
1341                 get_obj "type" (param, keytrace)
1342                 >>= fun (param_type, param_type_keytrace) ->
1343                 aux param_type ~keytrace:param_type_keytrace
1344                 >>= fun param_type ->
1345                 Ok
1346                   {
1347                     fp_type = { et_type = param_type; et_enforced = false };
1348                     fp_flags =
1349                       make_fp_flags
1350                         ~mode:callconv
1351                         ~accept_disposable:false
1352                         ~mutability:None
1353                         ~has_default:false
1354                         ~ifc_external:false
1355                         ~ifc_can_call:false
1356                         ~is_atom:false;
1357                     (* Dummy values: these aren't currently serialized. *)
1358                     fp_pos = Pos.none;
1359                     fp_name = None;
1360                     fp_rx_annotation = None;
1361                   })
1362           in
1363           params >>= fun ft_params ->
1364           get_obj "result" (json, keytrace) >>= fun (result, result_keytrace) ->
1365           aux result ~keytrace:result_keytrace >>= fun ft_ret ->
1366           ty
1367             (Tfun
1368                {
1369                  ft_params;
1370                  ft_implicit_params =
1371                    {
1372                      capability =
1373                        Typing_make_type.default_capability Reason.Rnone;
1374                    };
1375                  ft_ret = { et_type = ft_ret; et_enforced = false };
1376                  (* Dummy values: these aren't currently serialized. *)
1377                  ft_arity = Fstandard;
1378                  ft_tparams = [];
1379                  ft_where_constraints = [];
1380                  ft_flags = 0;
1381                  ft_reactive = Nonreactive;
1382                  ft_ifc_decl = default_ifc_fun_decl;
1383                })
1384         | _ ->
1385           deserialization_error
1386             ~message:
1387               (Printf.sprintf
1388                  "Unknown or unsupported kind '%s' to convert to locl phase"
1389                  kind)
1390             ~keytrace:kind_keytrace)
1391     and map_array :
1392         type a.
1393         Hh_json.json list ->
1394         f:
1395           (Hh_json.json ->
1396           keytrace:Hh_json.Access.keytrace ->
1397           (a, deserialization_error) result) ->
1398         keytrace:Hh_json.Access.keytrace ->
1399         (a list, deserialization_error) result =
1400      fun array ~f ~keytrace ->
1401       let array =
1402         List.mapi array ~f:(fun i elem ->
1403             f elem ~keytrace:(string_of_int i :: keytrace))
1404       in
1405       Result.all array
1406     and aux_args
1407         (args : Hh_json.json list) ~(keytrace : Hh_json.Access.keytrace) :
1408         (locl_ty list, deserialization_error) result =
1409       map_array args ~keytrace ~f:aux
1410     and aux_as (json : Hh_json.json) ~(keytrace : Hh_json.Access.keytrace) :
1411         (locl_ty, deserialization_error) result =
1412       Result.Monad_infix.(
1413         (* as-constraint is optional, check to see if it exists. *)
1414         match Hh_json.Access.get_obj "as" (json, keytrace) with
1415         | Ok (as_json, as_keytrace) ->
1416           aux as_json ~keytrace:as_keytrace >>= fun as_ty -> Ok as_ty
1417         | Error (Hh_json.Access.Missing_key_error _) ->
1418           Ok (mk (Reason.none, Toption (mk (Reason.none, Tnonnull))))
1419         | Error access_failure ->
1420           deserialization_error
1421             ~message:
1422               ( "Invalid as-constraint: "
1423               ^ Hh_json.Access.access_failure_to_string access_failure )
1424             ~keytrace)
1425     in
1426     aux json ~keytrace
1427 end
1428
1429 let to_json = Json.from_type
1430
1431 let json_to_locl_ty = Json.to_locl_ty
1432
1433 (*****************************************************************************)
1434 (* Prints the internal type of a class, this code is meant to be used for
1435  * debugging purposes only.
1436  *)
1437 (*****************************************************************************)
1438
1439 module PrintClass = struct
1440   let indent = "    "
1441
1442   let bool = string_of_bool
1443
1444   let sset s =
1445     let contents = SSet.fold (fun x acc -> x ^ " " ^ acc) s "" in
1446     Printf.sprintf "Set( %s)" contents
1447
1448   let pos p =
1449     let (line, start, end_) = Pos.info_pos p in
1450     Printf.sprintf "(line %d: chars %d-%d)" line start end_
1451
1452   let class_kind = function
1453     | Ast_defs.Cabstract -> "Cabstract"
1454     | Ast_defs.Cnormal -> "Cnormal"
1455     | Ast_defs.Cinterface -> "Cinterface"
1456     | Ast_defs.Ctrait -> "Ctrait"
1457     | Ast_defs.Cenum -> "Cenum"
1458
1459   let constraint_ty tcopt = function
1460     | (Ast_defs.Constraint_as, ty) -> "as " ^ Full.to_string_decl tcopt ty
1461     | (Ast_defs.Constraint_eq, ty) -> "= " ^ Full.to_string_decl tcopt ty
1462     | (Ast_defs.Constraint_super, ty) -> "super " ^ Full.to_string_decl tcopt ty
1463
1464   let variance = function
1465     | Ast_defs.Covariant -> "+"
1466     | Ast_defs.Contravariant -> "-"
1467     | Ast_defs.Invariant -> ""
1468
1469   let rec tparam
1470       tcopt
1471       {
1472         tp_variance = var;
1473         tp_name = (position, name);
1474         tp_tparams = params;
1475         tp_constraints = cstrl;
1476         tp_reified = reified;
1477         tp_user_attributes = _;
1478       } =
1479     let params_string =
1480       if List.is_empty params then
1481         ""
1482       else
1483         "<" ^ tparam_list tcopt params ^ ">"
1484     in
1485     variance var
1486     ^ pos position
1487     ^ " "
1488     ^ name
1489     ^ params_string
1490     ^ " "
1491     ^ List.fold_right
1492         cstrl
1493         ~f:(fun x acc -> constraint_ty tcopt x ^ " " ^ acc)
1494         ~init:""
1495     ^
1496     match reified with
1497     | Nast.Erased -> ""
1498     | Nast.SoftReified -> " soft reified"
1499     | Nast.Reified -> " reified"
1500
1501   and tparam_list ctx l =
1502     List.fold_right l ~f:(fun x acc -> tparam ctx x ^ ", " ^ acc) ~init:""
1503
1504   let class_elt ctx ({ ce_visibility; ce_type = (lazy ty); _ } as ce) =
1505     let vis =
1506       match ce_visibility with
1507       | Vpublic -> "public"
1508       | Vprivate _ -> "private"
1509       | Vprotected _ -> "protected"
1510     in
1511     let synth =
1512       if get_ce_synthesized ce then
1513         "synthetic "
1514       else
1515         ""
1516     in
1517     let type_ = Full.to_string_decl ctx ty in
1518     synth ^ vis ^ " " ^ type_
1519
1520   let class_elts tcopt m =
1521     List.fold m ~init:"" ~f:(fun acc (field, v) ->
1522         "(" ^ field ^ ": " ^ class_elt tcopt v ^ ") " ^ acc)
1523
1524   let class_elts_with_breaks tcopt m =
1525     List.fold m ~init:"" ~f:(fun acc (field, v) ->
1526         "\n" ^ indent ^ field ^ ": " ^ class_elt tcopt v ^ acc)
1527
1528   let class_consts tcopt m =
1529     List.fold m ~init:"" ~f:(fun acc (field, cc) ->
1530         let synth =
1531           if cc.cc_synthesized then
1532             "synthetic "
1533           else
1534             ""
1535         in
1536         "("
1537         ^ field
1538         ^ ": "
1539         ^ synth
1540         ^ Full.to_string_decl tcopt cc.cc_type
1541         ^ ") "
1542         ^ acc)
1543
1544   let typeconst
1545       tcopt
1546       {
1547         ttc_abstract = _;
1548         ttc_name = tc_name;
1549         ttc_constraint = tc_constraint;
1550         ttc_type = tc_type;
1551         ttc_origin = origin;
1552         ttc_enforceable = (_, enforceable);
1553         ttc_reifiable = reifiable;
1554       } =
1555     let name = snd tc_name in
1556     let ty x = Full.to_string_decl tcopt x in
1557     let constraint_ =
1558       match tc_constraint with
1559       | None -> ""
1560       | Some x -> " as " ^ ty x
1561     in
1562     let type_ =
1563       match tc_type with
1564       | None -> ""
1565       | Some x -> " = " ^ ty x
1566     in
1567     name
1568     ^ constraint_
1569     ^ type_
1570     ^ " (origin:"
1571     ^ origin
1572     ^ ")"
1573     ^ ( if enforceable then
1574         " (enforceable)"
1575       else
1576         "" )
1577     ^
1578     if Option.is_some reifiable then
1579       " (reifiable)"
1580     else
1581       ""
1582
1583   let typeconsts tcopt m =
1584     List.fold m ~init:"" ~f:(fun acc (_, v) ->
1585         "\n(" ^ typeconst tcopt v ^ ")" ^ acc)
1586
1587   let ancestors ctx m =
1588     (* Format is as follows:
1589      *    ParentKnownToHack
1590      *  ! ParentCompletelyUnknown
1591      *  ~ ParentPartiallyKnown  (interface|abstract|trait)
1592      *
1593      * ParentPartiallyKnown must inherit one of the ! Unknown parents, so that
1594      * sigil could be omitted *)
1595     List.fold m ~init:"" ~f:(fun acc (field, v) ->
1596         let (sigil, kind) =
1597           match Decl_provider.get_class ctx field with
1598           | None -> ("!", "")
1599           | Some cls ->
1600             ( ( if Cls.members_fully_known cls then
1601                 " "
1602               else
1603                 "~" ),
1604               " (" ^ class_kind (Cls.kind cls) ^ ")" )
1605         in
1606         let ty_str = Full.to_string_decl ctx v in
1607         "\n" ^ indent ^ sigil ^ " " ^ ty_str ^ kind ^ acc)
1608
1609   let constructor tcopt (ce_opt, (consist : consistent_kind)) =
1610     let consist_str = Format.asprintf "(%a)" pp_consistent_kind consist in
1611     let ce_str =
1612       match ce_opt with
1613       | None -> ""
1614       | Some ce -> class_elt tcopt ce
1615     in
1616     ce_str ^ consist_str
1617
1618   let req_ancestors tcopt xs =
1619     List.fold xs ~init:"" ~f:(fun acc (_p, x) ->
1620         acc ^ Full.to_string_decl tcopt x ^ ", ")
1621
1622   let class_type ctx c =
1623     let tenv = Typing_env.empty ctx (Pos.filename (Cls.pos c)) None in
1624     let tc_need_init = bool (Cls.need_init c) in
1625     let tc_members_fully_known = bool (Cls.members_fully_known c) in
1626     let tc_abstract = bool (Cls.abstract c) in
1627     let tc_deferred_init_members =
1628       sset
1629       @@
1630       if shallow_decl_enabled ctx then
1631         match Shallow_classes_provider.get ctx (Cls.name c) with
1632         | Some cls -> snd (Typing_deferred_members.class_ tenv cls)
1633         | None -> SSet.empty
1634       else
1635         Cls.deferred_init_members c
1636     in
1637     let tc_kind = class_kind (Cls.kind c) in
1638     let tc_name = Cls.name c in
1639     let tc_tparams = tparam_list ctx (Cls.tparams c) in
1640     let tc_consts = class_consts ctx (Cls.consts c) in
1641     let tc_typeconsts = typeconsts ctx (Cls.typeconsts c) in
1642     let tc_props = class_elts ctx (Cls.props c) in
1643     let tc_sprops = class_elts ctx (Cls.sprops c) in
1644     let tc_methods = class_elts_with_breaks ctx (Cls.methods c) in
1645     let tc_smethods = class_elts_with_breaks ctx (Cls.smethods c) in
1646     let tc_construct = constructor ctx (Cls.construct c) in
1647     let tc_ancestors = ancestors ctx (Cls.all_ancestors c) in
1648     let tc_req_ancestors = req_ancestors ctx (Cls.all_ancestor_reqs c) in
1649     let tc_req_ancestors_extends =
1650       String.concat ~sep:" " (Cls.all_ancestor_req_names c)
1651     in
1652     let tc_extends = String.concat ~sep:" " (Cls.all_extends_ancestors c) in
1653     "tc_need_init: "
1654     ^ tc_need_init
1655     ^ "\n"
1656     ^ "tc_members_fully_known: "
1657     ^ tc_members_fully_known
1658     ^ "\n"
1659     ^ "tc_abstract: "
1660     ^ tc_abstract
1661     ^ "\n"
1662     ^ "tc_deferred_init_members: "
1663     ^ tc_deferred_init_members
1664     ^ "\n"
1665     ^ "tc_kind: "
1666     ^ tc_kind
1667     ^ "\n"
1668     ^ "tc_name: "
1669     ^ tc_name
1670     ^ "\n"
1671     ^ "tc_tparams: "
1672     ^ tc_tparams
1673     ^ "\n"
1674     ^ "tc_consts: "
1675     ^ tc_consts
1676     ^ "\n"
1677     ^ "tc_typeconsts: "
1678     ^ tc_typeconsts
1679     ^ "\n"
1680     ^ "tc_props: "
1681     ^ tc_props
1682     ^ "\n"
1683     ^ "tc_sprops: "
1684     ^ tc_sprops
1685     ^ "\n"
1686     ^ "tc_methods: "
1687     ^ tc_methods
1688     ^ "\n"
1689     ^ "tc_smethods: "
1690     ^ tc_smethods
1691     ^ "\n"
1692     ^ "tc_construct: "
1693     ^ tc_construct
1694     ^ "\n"
1695     ^ "tc_ancestors: "
1696     ^ tc_ancestors
1697     ^ "\n"
1698     ^ "tc_extends: "
1699     ^ tc_extends
1700     ^ "\n"
1701     ^ "tc_req_ancestors: "
1702     ^ tc_req_ancestors
1703     ^ "\n"
1704     ^ "tc_req_ancestors_extends: "
1705     ^ tc_req_ancestors_extends
1706     ^ "\n"
1707     ^ ""
1708 end
1709
1710 module PrintTypedef = struct
1711   let typedef tcopt = function
1712     | { td_pos; td_vis = _; td_tparams; td_constraint; td_type } ->
1713       let tparaml_s = PrintClass.tparam_list tcopt td_tparams in
1714       let constr_s =
1715         match td_constraint with
1716         | None -> "[None]"
1717         | Some constr -> Full.to_string_decl tcopt constr
1718       in
1719       let ty_s = Full.to_string_decl tcopt td_type in
1720       let pos_s = PrintClass.pos td_pos in
1721       "ty: "
1722       ^ ty_s
1723       ^ "\n"
1724       ^ "tparaml: "
1725       ^ tparaml_s
1726       ^ "\n"
1727       ^ "constraint: "
1728       ^ constr_s
1729       ^ "\n"
1730       ^ "pos: "
1731       ^ pos_s
1732       ^ "\n"
1733       ^ ""
1734 end
1735
1736 (*****************************************************************************)
1737 (* User API *)
1738 (*****************************************************************************)
1739
1740 let error ?(ignore_dynamic = false) env ty =
1741   ErrorString.to_string ~ignore_dynamic env ty
1742
1743 let full env ty = Full.to_string ~ty:Full.locl_ty Doc.text env ty
1744
1745 let full_i env ty = Full.to_string ~ty:Full.internal_type Doc.text env ty
1746
1747 let full_rec env n ty = Full.to_string_rec env n ty
1748
1749 let full_strip_ns env ty = Full.to_string_strip_ns ~ty:Full.locl_ty env ty
1750
1751 let full_strip_ns_i env ty =
1752   Full.to_string_strip_ns ~ty:Full.internal_type env ty
1753
1754 let full_strip_ns_decl env ty = Full.to_string_strip_ns ~ty:Full.decl_ty env ty
1755
1756 let full_with_identity = Full.to_string_with_identity
1757
1758 let full_decl = Full.to_string_decl
1759
1760 let debug env ty =
1761   Full.debug_mode := true;
1762   let f_str = full_strip_ns env ty in
1763   Full.debug_mode := false;
1764   f_str
1765
1766 let debug_decl env ty =
1767   Full.debug_mode := true;
1768   let f_str = full_strip_ns_decl env ty in
1769   Full.debug_mode := false;
1770   f_str
1771
1772 let debug_i env ty =
1773   Full.debug_mode := true;
1774   let f_str = full_strip_ns_i env ty in
1775   Full.debug_mode := false;
1776   f_str
1777
1778 let class_ ctx c = PrintClass.class_type ctx c
1779
1780 let gconst ctx gc = Full.to_string_decl ctx gc
1781
1782 let fun_ ctx { fe_type; _ } = Full.to_string_decl ctx fe_type
1783
1784 let fun_type ctx f = Full.fun_to_string ctx f
1785
1786 let typedef ctx td = PrintTypedef.typedef ctx td
1787
1788 let constraints_for_type env ty =
1789   Full.constraints_for_type Doc.text env ty
1790   |> Option.map ~f:(Libhackfmt.format_doc_unbroken Full.format_env)
1791   |> Option.map ~f:String.strip
1792
1793 let class_kind c_kind final = ErrorString.class_kind c_kind final
1794
1795 let subtype_prop env prop =
1796   let rec subtype_prop = function
1797     | Conj [] -> "TRUE"
1798     | Conj ps ->
1799       "(" ^ String.concat ~sep:" && " (List.map ~f:subtype_prop ps) ^ ")"
1800     | Disj (_, []) -> "FALSE"
1801     | Disj (_, ps) ->
1802       "(" ^ String.concat ~sep:" || " (List.map ~f:subtype_prop ps) ^ ")"
1803     | IsSubtype (ty1, ty2) -> debug_i env ty1 ^ " <: " ^ debug_i env ty2
1804     | Coerce (ty1, ty2) -> debug env ty1 ^ " ~> " ^ debug env ty2
1805   in
1806   let p_str = subtype_prop prop in
1807   p_str
1808
1809 let coeffects env ty =
1810   let to_string ty =
1811     with_blank_tyvars (fun () ->
1812         Full.to_string
1813           ~ty:Full.locl_ty
1814           (fun s -> Doc.text (Utils.strip_all_ns s))
1815           env
1816           ty)
1817   in
1818   let exception UndesugarableCoeffect of locl_ty in
1819   let rec desugar_simple_intersection (ty : locl_ty) : string list =
1820     match snd @@ deref ty with
1821     | Tintersection tyl -> List.concat_map ~f:desugar_simple_intersection tyl
1822     | Tunion [ty] -> desugar_simple_intersection ty
1823     | Tunion _
1824     | Tnonnull
1825     | Tdynamic ->
1826       raise (UndesugarableCoeffect ty)
1827     | Toption ty' ->
1828       begin
1829         match deref ty' with
1830         | (_, Tnonnull) -> [] (* another special case of `mixed` *)
1831         | _ -> raise (UndesugarableCoeffect ty)
1832       end
1833     | _ -> [to_string ty]
1834   in
1835   "the capability "
1836   ^
1837   try
1838     "set {"
1839     ^ ( desugar_simple_intersection ty
1840       |> List.sort ~compare:String.compare
1841       |> String.concat ~sep:", " )
1842     ^ "}"
1843   with UndesugarableCoeffect _ -> to_string ty