Skip to content
This repository
tag: v334
Fetching contributors…

Cannot retrieve contributors at this time

file 232 lines (203 sloc) 7.955 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* depends *)
module Format = Base.Format

(* alias *)
module FieldSet = StringSet

(* shorthand *)
module J = JsAst
module Q = QmlAst

(* -- *)

let pp_esc fmt s = Format.fprintf fmt "%S" s
let pp_path fmt list = Format.pp_list " ; " pp_esc fmt list
let pp_fieldset fmt set =
  let sep = ref false in
  FieldSet.iter (
    fun field ->
      (if !sep then Format.fprintf fmt " ; " ; sep := true) ;
      Format.pp_print_string fmt field
  ) set


(* contains all the calls to the runtime (except the bsl which is called with
* bypasses) *)
module ClientLib =
struct
  let (!!) s = JsCons.Expr.native_global s

  let build_true = !! "build_true"
  let build_false = !! "build_false"
  let build_bool b = if b then build_true else build_false

  let dot_true = !! "dot_true"
  let dot_false = !! "dot_false"
  let dot_bool b = if b then dot_true else dot_false

  let error = !! "error"
  let extend_record = !! "extend_record"

  let match_failure pos =
    let message = JsCons.Expr.string (Format.sprintf "%a: Match failure" FilePos.pp_pos pos) in
    JsCons.Expr.call ~pure:false error [ message ]

  let size = !! "size"

  let void = !! "js_void"

  let type_string = !! "type_string"
  let type_char = !! "type_char"
  let type_int = !! "type_int"
  let type_float = !! "type_float"
  let type_fun = !! "type_fun"
  let type_fun_arity = !! "type_fun_arity"
  let type_var = !! "type_var"
  let type_option = !! "type_option"
  let type_void = !! "type_void"
  let type_native_option = !! "type_native_option"
  let type_native_void = !! "type_native_void"
  let type_bool = !! "type_bool"
  let type_extern = !! "type_extern"
  let type_opavalue = !! "type_opavalue"
  let assert_length = !! "assert_length"
end

(* a very conservative approximation of which expressions do observable side
* effects *)
let does_side_effects e =
  JsWalk.OnlyExpr.exists
    (function
     | J.Je_hole _
     | J.Je_new _
     | J.Je_call (_,_,_,false) -> true
     | J.Je_unop (_, ( J.Ju_delete
                     | J.Ju_add2_pre
                     | J.Ju_sub2_pre
                     | J.Ju_add2_post
                     | J.Ju_sub2_post), _) -> true
     | J.Je_binop (_, ( J.Jb_assign
                      | J.Jb_mul_assign
                      | J.Jb_div_assign
                      | J.Jb_mod_assign
                      | J.Jb_add_assign
                      | J.Jb_sub_assign
                      | J.Jb_lsl_assign
                      | J.Jb_lsr_assign
                      | J.Jb_asr_assign
                      | J.Jb_and_assign
                      | J.Jb_xor_assign
                      | J.Jb_or_assign ), _, _) -> true

     | J.Je_runtime (_, e) -> (
         match e with
         | JsAstRuntime.SetDistant _ -> true
         | JsAstRuntime.TaggedString _ -> false
       )
     | _ -> false
    ) e

(* ************************************************************************** *)
(** {b Descr}: Returns [true] if the type has some values that may be evaluated
into false in JS. The following types are considered "dangerous" because
the specified value is evaluated into false in JS:
- int : 0
- float : 0.0
- string : ""
- char : ''
- bool : false
- type variable since we do not know what it will finally be, perhaps
especially one of the above "dangerous" type.
- abstract type since we don't known what it is really.
- named type that remain named type after expansion since, if this
happens this means that we have no explicit representation of them
in term of basic types combinations, hence this probably corresponds
to an abstract type. Note that currently, with the way QML represents
abstract types, I'm really not sure that this can happen.
{b Visibility}: Not exported outside this module. *)
(* ************************************************************************** *)
let maybe_void gamma ty =
  let rec do_job ~already_expanded = function
    | Q.TypeRecord (Q.TyRow ([], _)) -> true
    | Q.TypeSum (Q.TyCol (list, colvar)) ->
        Option.is_some colvar
        || List.exists (function [] -> true | _ -> false) list
    | Q.TypeRecord _ | Q.TypeArrow _ | Q.TypeConst _ -> false
    | Q.TypeAbstract | Q.TypeVar _ -> true
    | Q.TypeSumSugar _ ->
        (* There should not remain such type at this point. *)
        assert false
    | Q.TypeForall (_, _, _, t) -> do_job ~already_expanded t
    | (Q.TypeName _) as t ->
        if already_expanded then true
        else (
          (* The type has not already been expanded, hence we are allowed to
expand it. *)
          let t = QmlTypesUtils.Inspect.follow_alias_noopt_private gamma t in
          (* And now it has been expanded, we are not allowed to expand it
again forever. *)
          do_job ~already_expanded: true t
        )
  in
  do_job ~already_expanded: false ty

let maybe_js_false gamma ty =
  (* Local function processing the type. We only expand the type if it appears
to be a named type.
This saves time in case the type is not a named one. The flag
[~already_expanded] tells if the type has been expanded, hence must not
be again. *)
  let rec do_job ~already_expanded = function

    (*
Special case for boolean.
Do not call Inspect.is_type_bool, because it would perform a expansion
everytime, and is not exactly what we need there.
We are caring about value that are potentially [false], which includes
bool value, but not only (e.g. with an open col, or row variable)
*)
    | Q.TypeRecord (Q.TyRow (["false", ty], _)) ->
        maybe_void gamma ty

    | Q.TypeRecord (Q.TyRow ([], Some _)) -> true

    | Q.TypeSum (Q.TyCol (cols, colvar)) ->
        let void = ref true in
        let exists case =
          match case with
          | [ "false", tyf ] ->
              void := maybe_void gamma tyf ;
              !void

          | _ -> false
        in
        List.exists exists cols
        || (Option.is_some colvar && !void)

    (*
From there, sum and record may not be bool
*)
    | Q.TypeRecord _ | Q.TypeArrow _ -> false
    | Q.TypeAbstract | Q.TypeVar _ -> true
    | Q.TypeConst ct -> (
        (* In fact, all basic types are "dangerous". *)
        match ct with
        | Q.TyFloat | Q.TyInt | Q.TyString -> true
        | Q.TyNull -> assert false
      )
    | Q.TypeSumSugar _ ->
        (* There should not remain such type at this point. *)
        assert false
    | Q.TypeForall (_, _, _, t) -> do_job ~already_expanded t
    | (Q.TypeName _) as t ->
        if already_expanded then true
        else (
          (* The type has not already been expanded, hence we are allowed to
expand it. *)
          let t = QmlTypesUtils.Inspect.follow_alias_noopt_private gamma t in
          (* And now it has been expanded, we are not allowed to expand it
again forever. *)
          do_job ~already_expanded: true t
        )
  in
  (* Now, really do the job. Effective body of the function [maybe_js_false]. *)
  do_job ~already_expanded: false ty



let const const =
  match const with
  | Q.Int i ->
      JsCons.Expr.int i
  | Q.Float f ->
      JsCons.Expr.float f
  | Q.String s ->
      JsCons.Expr.string s
Something went wrong with that request. Please try again.