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