Add Json example.

And add built-in knowledge that Js.Dict.t is an object.

Author: cristianoc

jscomp/core/js_exp_make.ml

@@ -772,31 +772,29 @@ let is_type_number ?comment (e : t) : t =
   string_equal ?comment (typeof e) (str "number")
 
 let rec is_a_literal_case ~(literal_cases : Lambda.literal list) ~block_cases (e:t) : t =
-  let is_literal_case (l:Lambda.literal) : t =
-    { expression_desc = Bin (EqEqEq, e, literal l); comment=None }
-     in
+  let is_literal_case (l:Lambda.literal) : t = bin EqEqEq e (literal l) in
   let is_block_case (c:Lambda.block_type) : t = match c with
-  | Lambda.StringType -> { expression_desc = Bin (NotEqEq, typeof e, str "string"); comment=None }
-  | IntType -> { expression_desc = Bin (NotEqEq, typeof e, str "number"); comment=None }
-  | FloatType -> { expression_desc = Bin (NotEqEq, typeof e, str "number"); comment=None }
-  | Array ->  { expression_desc = Bin (InstanceOf, e, str "object"); comment=None }
+  | StringType -> bin NotEqEq (typeof e) (str "string")
+  | IntType -> bin NotEqEq (typeof e) (str "number")
+  | FloatType -> bin NotEqEq (typeof e) (str "number")
+  | Array ->  not (bin InstanceOf e (str "Array" ~delim:DNoQuotes))
   | Object ->  { expression_desc = Bin (NotEqEq, typeof e, str "object"); comment=None }
   | Unknown ->
     (* We don't know the type of unknown, so we need to express:
        this is not one of the literals *)
     (match literal_cases with
       | [] -> { expression_desc = Bool true; comment=None}
       | l1 :: others ->
-        let is_litera_1 = is_literal_case l1 in
-        Ext_list.fold_right others is_litera_1 (fun literal_n acc ->
-          { J.expression_desc = Bin (Or, is_literal_case literal_n, acc); comment = None }
+        let is_literal_1 = is_literal_case l1 in
+        Ext_list.fold_right others is_literal_1 (fun literal_n acc ->
+          bin Or (is_literal_case literal_n) acc
         )
     )
   in
   match block_cases with
   | [c] -> is_block_case c
   | c1 :: (_::_ as rest) ->
-    { J.expression_desc = Bin (And, is_block_case c1, is_a_literal_case ~literal_cases ~block_cases:rest e ); comment = None }
+    bin And (is_block_case c1) (is_a_literal_case ~literal_cases ~block_cases:rest e)
   | [] -> assert false
 
 let is_tag ?(has_null_undefined_other=(false, false, false)) (e : t) : t =

jscomp/core/matching_polyfill.ml

@@ -54,26 +54,33 @@ let names_from_construct_pattern (pat : Typedtree.pattern) =
         literal = Ast_attributes.process_as_value cstr.cd_attributes } in
     let get_tag_name (cstr: Types.constructor_declaration) =
       Ast_attributes.process_tag_name cstr.cd_attributes in
-    let get_untagged (cstr: Types.constructor_declaration) =
+    let get_untagged (cstr: Types.constructor_declaration) : Lambda.block_type option =
       match Ast_attributes.process_untagged cstr.cd_attributes, cstr.cd_args with
       | false, _ -> None
       | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_string ->
-          Some Lambda.StringType
+          Some StringType
       | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_int ->
           Some IntType
       | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_float ->
           Some FloatType
       | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path.same path Predef.path_array ->
           Some Array
+      | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] when Path. same path Predef.path_string ->
+          Some StringType
+      | true, Cstr_tuple [{desc = Tconstr (path, _, _)}] ->
+        (match Path.name path with
+        | "Js.Dict.t"
+        | "Js_dict.t" -> Some Object
+        | _ -> Some Unknown)
       | true, Cstr_tuple (_ :: _ :: _) ->
           (* C(_, _) with at least 2 args is an object *)
           Some Object
-      | true, Cstr_record _ ->
-          (* inline record is an object *)
-          Some Object
       | true, Cstr_tuple [_] ->
           (* Every other single payload is unknown *)
           Some Unknown
+      | true, Cstr_record _ ->
+          (* inline record is an object *)
+          Some Object
       | true, _ -> None (* TODO: add restrictions here *)
     in
     let get_block cstr : Lambda.block =

jscomp/test/UntaggedVariants.js

@@ -168,6 +168,49 @@ var WithArray = {
   classify: classify$5
 };
 
+function classify$6(x) {
+  if (!(x instanceof Array) && typeof x !== "object" && typeof x !== "number" && typeof x !== "string") {
+    switch (x) {
+      case false :
+          return "JSONFalse";
+      case true :
+          return "JSONTrue";
+      case null :
+          return "JSONNull";
+      
+    }
+  } else {
+    if (x instanceof Array) {
+      return {
+              TAG: "JSONArray",
+              _0: x
+            };
+    }
+    switch (typeof x) {
+      case "string" :
+          return {
+                  TAG: "JSONString",
+                  _0: x
+                };
+      case "number" :
+          return {
+                  TAG: "JSONNumber",
+                  _0: x
+                };
+      case "object" :
+          return {
+                  TAG: "JSONObject",
+                  _0: x
+                };
+      
+    }
+  }
+}
+
+var Json = {
+  classify: classify$6
+};
+
 var i = 42;
 
 var i2 = 42.5;
@@ -200,4 +243,5 @@ exports.Unknown = Unknown;
 exports.MultipleBlocks = MultipleBlocks;
 exports.OnlyBlocks = OnlyBlocks;
 exports.WithArray = WithArray;
+exports.Json = Json;
 /* l2 Not a pure module */

jscomp/test/UntaggedVariants.res

@@ -122,14 +122,64 @@ module OnlyBlocks = {
 
 module WithArray = {
   @unboxed
-  type t<'a> = String(string) | Float(float) | Array(array<string>)| Object({name: string}) 
+  type t<'a> = String(string) | Float(float) | Array(array<string>) | Object({name: string})
 
   let classify = x =>
     switch x {
     | String(_) => "string"
     | Float(_) => "int"
-    | Array(_) when true => "array"
+    | Array(_) if true => "array"
     | Array(_) => "array"
     | Object({name}) => "Object" ++ name
     }
 }
+
+module Json = {
+  @unboxed
+  type rec t =
+    | @as(false) False
+    | @as(true) True
+    | @as(null) Null
+    | String(string)
+    | Number(float)
+    | Object(Js.Dict.t<t>)
+    | Array(array<t>)
+
+  type tagged_t =
+    | JSONFalse
+    | JSONTrue
+    | JSONNull
+    | JSONString(string)
+    | JSONNumber(float)
+    | JSONObject(Js.Dict.t<t>)
+    | JSONArray(array<t>)
+
+  let classify = (x: t) =>
+    switch x {
+    | False => JSONFalse
+    | True => JSONTrue
+    | Null => JSONNull
+    | String(s) => JSONString(s)
+    | Number(n) => JSONNumber(n)
+    | Object(o) => JSONObject(o)
+    | Array(a) => JSONArray(a)
+    }
+
+  /* from js_json.ml
+let classify  (x : t) : tagged_t =
+  let ty = Js.typeof x in
+  if ty = "string" then
+    JSONString (Obj.magic x)
+  else if ty = "number" then
+    JSONNumber (Obj.magic x )
+  else if ty = "boolean" then
+    if (Obj.magic x) = true then JSONTrue
+    else JSONFalse
+  else if (Obj.magic x) == Js.null then
+    JSONNull
+  else if Js_array2.isArray x  then
+    JSONArray (Obj.magic x)
+  else
+    JSONObject (Obj.magic x)  
+ */
+}