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