hphp/hack/src/typing/tast_check/type_test_hint_check.ml

   1 (**
   2  * Copyright (c) 2018, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the MIT license found in the
   6  * LICENSE file in the "hack" directory of this source tree.
   7  *
   8  *)
   9
  10 open Core_kernel
  11 open Tast
  12 open Typing_defs
  13
  14 module Env = Tast_env
  15 module Reason = Typing_reason
  16 module TySet = Typing_set
  17 module Cls = Typing_classes_heap
  18
  19 type validity =
  20   | Valid
  21   | Invalid: Reason.t * string -> validity
  22
  23 type validation_state = {
  24   env: Env.env;
  25   validity: validity;
  26 }
  27
  28 let update state new_validity =
  29   if state.validity = Valid
  30   then { state with validity = new_validity }
  31   else state
  32
  33 let visitor = object(this)
  34   inherit [validation_state] Type_visitor.type_visitor as _super
  35   (* Only comes about because naming has reported an error and left Hany *)
  36   method! on_tany acc _ = acc
  37   (* Already reported an error *)
  38   method! on_terr acc _ = acc
  39   method! on_tprim acc r prim =
  40     match prim with
  41       | Aast.Tvoid -> update acc @@ Invalid (r, "the void type")
  42       | Aast.Tnoreturn -> update acc @@ Invalid (r, "the noreturn type")
  43       | _ -> acc
  44   method! on_tfun acc r _fun_type = update acc @@ Invalid (r, "a function type")
  45   method! on_tvar acc r _id = update acc @@ Invalid (r, "an unknown type")
  46   method! on_tabstract acc r ak _ty_opt =
  47     match ak with
  48     | AKenum _ -> acc
  49     | AKdependent (`this, _) -> acc
  50     | AKgeneric name when Env.is_fresh_generic_parameter name -> acc
  51     | AKgeneric name when AbstractKind.is_generic_dep_ty name ->
  52       (* The when constraint guarnatees that there is a :: in the name *)
  53       let acc = match Str.split (Str.regexp_string "::") name with
  54       | [class_id; tconst_id] ->
  55         (* If a Taccess resolves to an abstract type constant, it will be given
  56          * to this visitor as a Tabstract, and the recursive bounds check below
  57          * will eventually resolve to the abstract type constant's constraint.
  58          * However, a subtype of this constraint could have a type parameter, so
  59          * we check whether the abstract type constant is enforceable. In the case
  60          * where Taccess is concrete, the locl ty will have resolved to a
  61          * Tclass/Tprim/etc, so it won't be checked by this method *)
  62         let open Option in
  63         let tconst_opt = Env.get_class acc.env class_id >>=
  64           (fun cls -> Cls.get_typeconst cls tconst_id) in
  65         Option.value_map ~default:acc tconst_opt ~f:(fun tconst ->
  66           if not (snd tconst.ttc_enforceable)
  67           then update acc @@
  68             Invalid (r, "the abstract type constant " ^
  69               tconst_id ^ " because it is not marked <<__Enforceable>>")
  70           else acc
  71         )
  72       | _ ->
  73         acc in
  74
  75
  76       let bounds = TySet.elements (Env.get_upper_bounds acc.env name) in
  77       List.fold_left bounds ~f:this#on_type ~init:acc
  78     | AKgeneric name ->
  79       begin match Env.get_reified acc.env name, Env.get_enforceable acc.env name with
  80       | Nast.Erased, _ -> update acc @@
  81         Invalid (r, "an erased generic type parameter")
  82       | Nast.SoftReified, _ -> update acc @@
  83         Invalid (r, "a soft reified generic type parameter")
  84       | Nast.Reified, false -> update acc @@
  85         Invalid (r, "a reified type parameter that is not marked <<__Enforceable>>")
  86       | Nast.Reified, true ->
  87         acc end
  88     | AKnewtype _ -> update acc @@ Invalid (r, "a newtype")
  89     | AKdependent _ -> update acc @@ Invalid (r, "an expression dependent type")
  90   method! on_tanon acc r _arity _id =
  91     update acc @@ Invalid (r, "a function type")
  92   method! on_tunresolved acc r _tyl =
  93     update acc @@ Invalid (r, "a union")
  94   method! on_tobject acc r = update acc @@ Invalid (r, "the object type")
  95   method! on_tclass acc r cls _ tyl =
  96     match Env.get_class acc.env (snd cls) with
  97     | Some tc ->
  98       let tparams = Cls.tparams tc in
  99       begin match tyl with
 100       | [] -> acc (* this case should really be handled by the fold2,
 101         but we still allow class hints without args in certain places *)
 102       | tyl ->
 103         let open List.Or_unequal_lengths in
 104         begin match List.fold2 ~init:acc tyl tparams ~f:(fun acc targ tparam ->
 105           if this#is_wildcard targ
 106           then acc
 107           else
 108             match tparam.tp_reified with
 109             | Nast.Erased -> update acc @@ Invalid (r, "a type with an erased generic type argument")
 110             | Nast.SoftReified -> update acc @@ Invalid (r, "a type with a soft reified type argument")
 111             | Nast.Reified -> this#on_type acc targ
 112         ) with
 113         | Ok new_acc -> new_acc
 114         | Unequal_lengths -> acc (* arity error elsewhere *)
 115         end
 116       end
 117     | None -> acc
 118   method! on_tapply acc r (_, name) tyl =
 119     if tyl <> [] && Typing_env.is_typedef name
 120     then update acc @@ Invalid (r, "a type with generics, because generics are erased at runtime")
 121     else acc
 122   method! on_tarraykind acc r _array_kind =
 123     update acc @@ Invalid (r, "an array type")
 124   method is_wildcard = function
 125     | _, Tabstract (AKgeneric name, _) ->
 126       Env.is_fresh_generic_parameter name
 127     | _ -> false
 128 end
 129
 130 let validate_hint env hint emit_error =
 131   let hint_ty = Env.hint_to_ty env hint in
 132   let should_suppress = ref false in
 133   let validate_type env ty =
 134     let state = visitor#on_type {env = env; validity = Valid} ty in
 135     match state.validity with
 136       | Invalid (r, msg) ->
 137         if not !should_suppress
 138         then emit_error (fst hint) (Reason.to_pos r) msg;
 139         should_suppress := true
 140       | Valid -> ()
 141   in
 142   let env, hint_ty = Env.localize_with_dty_validator
 143     env hint_ty (validate_type env) in
 144   validate_type env hint_ty
 145
 146 let handler = object
 147   inherit Tast_visitor.handler_base
 148   method! at_expr env = function
 149     | _, Is (_, hint) -> validate_hint env hint (Errors.invalid_is_as_expression_hint "is")
 150     | _, As (_, hint, _) -> validate_hint env hint (Errors.invalid_is_as_expression_hint "as")
 151     | _ -> ()
 152 end