hphp/hack/src/h2tp/mapper/unsupported_constructs.ml

   1 (**
   2  * Copyright (c) 2015, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the BSD-style license found in the
   6  * LICENSE file in the "hack" directory of this source tree. An additional grant
   7  * of patent rights can be found in the PATENTS file in the same directory.
   8  *
   9  *)
  10
  11 module M = Map_ast
  12 module CE = Common_exns
  13 module List = Core_list
  14 open Ast
  15 open Ast_ext
  16
  17 let map program =
  18   let errors = ref [] in
  19
  20   let unsupported (p, m) =
  21     errors := (CE.ConversionError (p, m)) :: !errors;
  22     () in
  23
  24   let detect_invalid_attributes p attributes =
  25     if List.exists ~f:(fun { ua_name; _ } -> "__Memoize" = snd ua_name) attributes
  26     then unsupported (p, "__Memoize is currently not supported.")
  27     else () in
  28
  29   let detect_invalid_fun_kind p = function
  30     | FSync | FGenerator -> ()
  31     | FAsync | FAsyncGenerator ->
  32       unsupported (p, "async is currently not supported.") in
  33
  34   let detect_invalid_fun {f_user_attributes; f_fun_kind; f_name = (p, _); _} =
  35     detect_invalid_attributes p f_user_attributes;
  36     detect_invalid_fun_kind p f_fun_kind in
  37
  38   let detect_invalid_method {m_user_attributes; m_fun_kind; m_name = (p, _); _} =
  39     detect_invalid_attributes p m_user_attributes;
  40     detect_invalid_fun_kind p m_fun_kind in
  41
  42   let detect_invalid_collection p name afields =
  43     match (base_collection_str name, afields) with
  44     | (Some "\\HH\\Pair", [AFvalue _; AFvalue _]) -> ()
  45     | (Some "\\HH\\Pair", _) ->
  46         unsupported (p, "Invalid initialization of Pair")
  47     | (Some "\\HH\\Map", _) | (Some "\\HH\\ImmMap", _) ->
  48         (** TODO: task 10395133. support dict *)
  49         List.iter ~f:begin function
  50           | AFkvalue _ -> ()
  51           | AFvalue (p, _) ->
  52               unsupported (p, "Invalid Initialization of " ^ name)
  53           end afields
  54     | (None, _) ->
  55         unsupported (p, "Unsupported collection type " ^ name)
  56     | _ -> ()  in
  57
  58   let detect_invalid_expr = function
  59     | (p, Await _) ->
  60         unsupported (p, "await is currently not supported.")
  61     | (_, Collection ((p, name), afields)) ->
  62         detect_invalid_collection p name afields;
  63         ()
  64     | _ -> () in
  65
  66   let detect_invalid_class_var = function
  67     | ((p, _), Some (_, Collection _)) ->
  68         let m = "Collection initializers in instance variables are currently" ^
  69           " not supported." in
  70         unsupported (p, m)
  71     | _ -> () in
  72
  73   let detect_invalid_class_elt = function
  74     | ClassVars (kinds, _, class_vars) when not (List.mem kinds Static) ->
  75         List.iter ~f:detect_invalid_class_var class_vars;
  76         ()
  77     | _ -> () in
  78
  79   let detect_invalid_class = function
  80     | {c_name = (p, _); c_kind = Ctrait; c_implements = _::_; _} ->
  81       unsupported (p,
  82         "Traits implementing interfaces are currently not supported. ")
  83     | _ -> () in
  84
  85   let mapper = M.mk_program_mapper { M.default_mapper with
  86     M.k_class_ = (fun (k, _) c ->
  87       detect_invalid_class c;
  88       k c);
  89     M.k_class_elt = (fun (k, _) _ elt ->
  90       detect_invalid_class_elt elt;
  91       k elt
  92       );
  93     M.k_fun_ = (fun (k, _) fun_ ->
  94       detect_invalid_fun fun_;
  95       k fun_);
  96     M.k_method_ = (fun (k, _) _ method_ ->
  97       detect_invalid_method method_;
  98       k method_);
  99     M.k_expr = (fun (k, _) e -> detect_invalid_expr e; k e);
 100   } in
 101   ignore (mapper program);
 102   if not (List.is_empty !errors)
 103   then raise (CE.CompoundError !errors);
 104   program (* this mapper does no mapping *)