hphp/hack/src/typing/typing_ops.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 open Core_kernel
  11
  12 module Reason  = Typing_reason
  13 module Env     = Typing_env
  14 module SubType = Typing_subtype
  15 module Phase   = Typing_phase
  16 module MakeType = Typing_make_type
  17
  18 (*****************************************************************************)
  19 (* Exporting. *)
  20 (*****************************************************************************)
  21
  22 (* Tries to add constraint that ty_sub is subtype of ty_super in envs *)
  23 let sub_type p ur env ty_sub ty_super =
  24   Typing_log.(log_with_level env "sub" 1 (fun () ->
  25     log_types p env
  26     [Log_head ("Typing_ops.sub_type",
  27        [Log_type ("ty_sub", ty_sub);
  28         Log_type ("ty_super", ty_super)])]));
  29   let env = { env with Env.pos = p; Env.outer_pos = p; Env.outer_reason = ur } in
  30   Errors.try_add_err p (Reason.string_of_ureason ur)
  31     (fun () -> SubType.sub_type env ty_sub ty_super)
  32     (fun () -> env)
  33
  34 let coerce_type ?sub_fn:(sub=sub_type) p ur env ty_have ty_expect =
  35   Typing_coercion.coerce_type ~sub_fn:sub p ur env ty_have ty_expect
  36
  37 let can_coerce env ty_have ty_expect =
  38   Typing_coercion.can_coerce env ty_have ty_expect
  39
  40 let sub_type_decl p ur env ty_sub ty_super =
  41   let env, ty_super = Phase.localize_with_self env ty_super in
  42   let env, ty_sub = Phase.localize_with_self env ty_sub in
  43   ignore (sub_type p ur env ty_sub ty_super)
  44
  45 (* Ensure that types are equivalent i.e. subtypes of each other *)
  46 let unify_decl p ur env ty1 ty2 =
  47   let env, ty1 = Phase.localize_with_self env ty1 in
  48   let env, ty2 = Phase.localize_with_self env ty2 in
  49   ignore (sub_type p ur env ty2 ty1);
  50   ignore (sub_type p ur env ty1 ty2)
  51
  52 module LeastUpperBound = struct
  53   open Typing_defs
  54   open Nast
  55
  56   let exact_least_upper_bound e1 e2 =
  57   match e1, e2 with
  58   | Exact, Exact -> Exact
  59   | _, _ -> Nonexact
  60
  61   let prim_least_up_bound tprim1 tprim2 =
  62     match tprim1, tprim2 with
  63     | Tint, Tstring | Tstring, Tint -> Some Tarraykey
  64     | Tint, Tfloat | Tfloat, Tint -> Some Tnum
  65     | _ , _ -> None
  66
  67   let rec type_visitor ~f ~default ty1 ty2 =
  68   let array_kind ak1 ak2 =
  69       match ak1, ak2 with
  70       | AKmap (ty1, ty2), AKmap (ty3, ty4) ->
  71         let ty1_ = type_visitor ~f ~default ty1 ty3 in
  72         let ty2_ = type_visitor ~f ~default ty2 ty4 in
  73         Some (AKmap (ty1_, ty2_))
  74       | AKdarray (ty1, ty2), AKdarray (ty3, ty4) ->
  75         let ty1_ = type_visitor ~f ~default ty1 ty3 in
  76         let ty2_ = type_visitor ~f ~default ty2 ty4 in
  77         Some (AKdarray (ty1_, ty2_))
  78       | AKvarray ty1, AKvarray ty2 ->
  79         let ty = type_visitor ~f ~default ty1 ty2 in
  80         Some (AKvarray ty)
  81       | AKvec ty1, AKvec ty2 ->
  82         let ty = type_visitor ~f ~default ty1 ty2 in
  83         Some (AKvec ty)
  84       | _ -> None
  85     in
  86     let (r1, ty_1), (_, ty_2) = (ty1, ty2) in
  87     match ty_1, ty_2 with
  88       | Ttuple tyl1, Ttuple tyl2 ->
  89         begin try let tyl = List.map2_exn ~f:(type_visitor ~f ~default) tyl1 tyl2 in
  90           r1, Ttuple tyl
  91           with _ -> default
  92         end
  93       | Tclass ((p, id1), e1, tyl1), Tclass((_, id2), e2, tyl2) ->
  94         if id1 = id2 then
  95           begin try let tyl = List.map2_exn ~f:(type_visitor ~f ~default) tyl1 tyl2 in
  96             r1, Tclass ((p, id1), exact_least_upper_bound e1 e2, tyl)
  97             with _ -> default
  98           end
  99         else
 100           default
 101       | Tarraykind ak1, Tarraykind ak2 ->
 102         begin match array_kind ak1 ak2 with
 103         | None -> default
 104         | Some ak -> r1, Tarraykind ak
 105         end
 106       | Tprim tprim1, Tprim tprim2 ->
 107         begin match prim_least_up_bound tprim1 tprim2 with
 108         | None -> f ty1 ty2
 109         | Some ty -> r1, Tprim ty
 110         end
 111       | Toption ty1, Toption ty2 ->
 112         let ty = type_visitor ~f ~default ty1 ty2 in r1, Toption ty
 113       | Toption ty1 , ty_2 | ty_2, Toption ty1 ->
 114         let ty = type_visitor ~f ~default ty1 (r1, ty_2) in r1, Toption ty
 115       | _ -> f ty1 ty2
 116
 117   (* @TODO expand this match to refine more types*)
 118   let pairwise_least_upper_bound env ~default ty1 ty2 =
 119     if SubType.is_sub_type env ty1 ty2 then ty2
 120     else if SubType.is_sub_type env ty2 ty1 then ty1
 121     else default
 122
 123   let rec full env types =
 124     match types with
 125     | [] -> None
 126     | [t] -> Some t
 127     | (r, _ as ty1) :: ty2 :: ts ->
 128       let default = MakeType.mixed r in
 129       let ty =
 130         type_visitor
 131           ~f:(pairwise_least_upper_bound env ~default)
 132           ~default ty1 ty2
 133       in
 134       full env (ty :: ts)
 135
 136   let rec compute types =
 137     match types with
 138     | [] -> None
 139     | [t] ->  Some t
 140     | (tenv, p, k, (r, _ as ty1)) :: (_, _, _, ty2) :: ts  ->
 141       let default = MakeType.mixed r in
 142       let ty =
 143         type_visitor
 144           ~f:(pairwise_least_upper_bound tenv ~default)
 145           ~default ty1 ty2
 146       in
 147       compute ((tenv, p, k, ty) :: ts)
 148
 149   end