Done (+4 squashed commits)

Squashed commits: [a590f3a] works [5a47c08] WIp [5390ab1] ready for reading from prim_native_name [cb4da50] move files -- preparing store metata in native name
rescript-lang · Jul 25, 2016 · a2c06ee · a2c06ee
1 parent 9e342d7
commit a2c06ee
Show file tree

Hide file tree

Showing 15 changed files with 90 additions and 41 deletions.
diff --git a/jscomp/bs_loc.ml → jscomp/common/bs_loc.ml b/jscomp/bs_loc.ml → jscomp/common/bs_loc.ml
diff --git a/jscomp/bs_loc.mli → jscomp/common/bs_loc.mli b/jscomp/bs_loc.mli → jscomp/common/bs_loc.mli
diff --git a/jscomp/common/common.mllib b/jscomp/common/common.mllib
@@ -1,4 +1,5 @@
 js_config
 literals
 ext_log
-
+bs_loc
+lam_methname
diff --git a/jscomp/lam_methname.ml → jscomp/common/lam_methname.ml b/jscomp/lam_methname.ml → jscomp/common/lam_methname.ml
diff --git a/jscomp/lam_methname.mli → jscomp/common/lam_methname.mli b/jscomp/lam_methname.mli → jscomp/common/lam_methname.mli
diff --git a/jscomp/core.mllib b/jscomp/core.mllib
@@ -5,7 +5,7 @@ ident_util
 idents_analysis
 config_util
 
-bs_loc
+
 
 ocaml_options
 ocaml_batch_compile
@@ -14,7 +14,7 @@ ocaml_parse
 lam
 lam_iter
 lam_print
-lam_external_def
+
 lam_compile_env
 lam_dispatch_primitive
 lam_stats
@@ -44,7 +44,7 @@ lam_dce
 lam_analysis
 lam_group
 
-lam_methname 
+
 
 j
 js_ast_util

diff --git a/jscomp/ext/ext_pervasives.mli b/jscomp/ext/ext_pervasives.mli
@@ -50,4 +50,4 @@ val bad_argf : ('a, unit, string, 'b) format4 -> 'a
 
 
 val dump : 'a -> string 
-[@@ocaml.deprecated "only for debugging purpose"]
+
diff --git a/jscomp/lam_compile_external_call.ml b/jscomp/lam_compile_external_call.ml
@@ -30,7 +30,7 @@ module E = Js_exp_make
 
 
 let handle_external 
-    (module_name : Lam_external_def.external_module_name option) = 
+    (module_name : Ast_external_attributes.external_module_name option) = 
   match module_name with 
   | Some {bundle ; bind_name} -> 
     let id  = 
@@ -48,7 +48,7 @@ type typ = Ast_core_type.t
 
 let ocaml_to_js last
     (js_splice : bool)
-    ({ Lam_external_def.arg_label;  arg_type = ty })
+    ({ Ast_external_attributes.arg_label;  arg_type = ty })
     (arg : J.expression) 
   : E.t list = 
   if last && js_splice 
@@ -84,7 +84,7 @@ let ocaml_to_js last
 
 
 
-let translate_ffi (ffi : Lam_external_def.ffi ) prim_name
+let translate_ffi (ffi : Ast_external_attributes.ffi ) prim_name
     (cxt  : Lam_compile_defs.cxt)
     arg_types result_type
     (args : J.expression list) = 
@@ -244,17 +244,18 @@ let translate_ffi (ffi : Lam_external_def.ffi ) prim_name
 
 
 let translate cxt 
-    ({prim_name ; } as prim 
-     : Lam_external_def.prim) args  = 
-  match Lam_external_def.handle_attributes prim with 
-  | Normal -> Lam_dispatch_primitive.translate prim_name args 
-  | Bs (arg_types, result_type, ffi) -> 
-    translate_ffi  ffi prim_name cxt arg_types result_type args 
-
-
+    ({prim_name ; prim_attributes; prim_native_name} 
+     : Ast_external_attributes.prim) args  = 
+  if Ast_external_attributes.is_bs_external_prefix prim_native_name then 
+    begin 
+      match Ast_external_attributes.unsafe_from_string prim_native_name with 
+      | Normal -> 
+        Lam_dispatch_primitive.translate prim_name args 
+      | Bs (arg_types, result_type, ffi) -> 
+        translate_ffi  ffi prim_name cxt arg_types result_type args 
+    end
+  else 
+    begin 
+      Lam_dispatch_primitive.translate prim_name args 
+    end
 
-(* TODO:
-  Also need to mark that CamlPrimtivie is used and
-  add such dependency in
-  module loader 
-*)
diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml
@@ -199,7 +199,7 @@ let process_bs_int_as  attrs =
         ->
         begin match Ast_payload.is_single_int payload with 
           | None -> 
-            Location.raise_errorf ~loc "expect string literal "
+            Location.raise_errorf ~loc "expect int literal "
           | Some  _ as v->  v  
         end
       | "bs.as",  _ 

diff --git a/jscomp/lam_external_def.ml → jscomp/syntax/ast_external_attributes.ml b/jscomp/lam_external_def.ml → jscomp/syntax/ast_external_attributes.ml
@@ -163,13 +163,8 @@ type t  =
   | Normal 
   (* When it's normal, it is handled as normal c functional ffi call *)
 
-let handle_attributes ({prim_attributes ; prim_name}   : prim )  = 
-  let typ, prim_attributes =
-    Ast_attributes.process_bs_type prim_attributes in
-  match typ with
-  | None ->  Normal
-  | Some type_annotation ->
-    (* all bs ffi should come with types *)
+let handle_attributes (type_annotation : Parsetree.core_type)
+    (prim_attributes : Ast_attributes.t) (prim_name : string) = 
     let name_from_payload_or_prim payload = 
       match Ast_payload.is_single_string payload with 
       | Some _ as val_name ->  val_name
@@ -383,3 +378,19 @@ let handle_attributes ({prim_attributes ; prim_name}   : prim )  =
     check_ffi ~loc ffi;
     Bs(arg_types, result_type,  ffi)
 
+let bs_external = "BS_EXTERN:" ^ Js_config.version
+
+let bs_external_length = (String.length bs_external)
+
+let is_bs_external_prefix s = 
+  Ext_string.starts_with s bs_external
+
+let to_string  t = 
+  bs_external ^ Marshal.to_string t []
+let unsafe_from_string s = 
+    Marshal.from_string  s bs_external_length 
+
+let from_string s : t  = 
+  if is_bs_external_prefix s then 
+    Marshal.from_string  s (String.length bs_external)
+  else Ext_pervasives.failwithf ~loc:__LOC__ "compiler version mismatch, please do a clean build" 
diff --git a/jscomp/lam_external_def.mli → jscomp/syntax/ast_external_attributes.mli b/jscomp/lam_external_def.mli → jscomp/syntax/ast_external_attributes.mli
@@ -45,8 +45,6 @@ type js_send = {
 
 type js_val = string external_module 
 
-
-
 type arg_type =
   [ `NullString of (int * string) list 
   | `NonNullString of (int * string) list 
@@ -85,4 +83,11 @@ type prim = Types.type_expr option Primitive.description
 
 
 
-val handle_attributes : prim -> t
+val handle_attributes : Parsetree.core_type  -> Ast_attributes.t -> string -> t
+
+val bs_external : string 
+val to_string : t -> string 
+val from_string : string -> t 
+val unsafe_from_string : string -> t 
+val is_bs_external_prefix : string -> bool
+
diff --git a/jscomp/syntax/ast_util.ml b/jscomp/syntax/ast_util.ml
@@ -419,9 +419,12 @@ let record_as_js_object
         | Ldot _ | Lapply _ ->  
           Location.raise_errorf ~loc "invalid js label "
   ) label_exprs in 
-  let pval_prim = [ "" ] in 
+
   let pval_type = from_labels ~loc labels in 
   let pval_attributes = Ast_attributes.bs_obj pval_type in 
+  let pval_prim = 
+    [ "" ; 
+      Ast_external_attributes.(to_string (handle_attributes pval_type pval_attributes ""))] in 
   Ast_external.create_local_external loc 
     ~pval_prim
     ~pval_type ~pval_attributes 

diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml
@@ -462,17 +462,33 @@ let rec unsafe_mapper : Ast_mapper.mapper =
         end
       | Psig_value
           ({pval_attributes; 
-            pval_type; pval_loc} as prim) 
+            pval_type; 
+            pval_loc;
+            pval_prim;
+            pval_name ;
+           } as prim) 
         when Ast_attributes.process_external pval_attributes
         -> 
         let pval_type = self.typ self pval_type in 
+        let pval_attributes =
+          (Ast_attributes.mk_bs_type ~loc:pval_loc pval_type)
+          :: pval_attributes in
+        let pval_prim = 
+          match pval_prim with 
+          | [ v ] -> 
+            [ v; 
+              Ast_external_attributes.(
+                to_string @@ handle_attributes pval_type pval_attributes v)
+            ]
+          | _ -> Location.raise_errorf "only a single string is allowed in bs external" in
         {sigi with 
          psig_desc = 
            Psig_value
              {prim with
               pval_type ; 
-              pval_attributes = 
-                (Ast_attributes.mk_bs_type ~loc:pval_loc pval_type) :: pval_attributes }}
+              pval_prim ;
+              pval_attributes 
+                 }}
 
       | _ -> Ast_mapper.default_mapper.signature_item self sigi
     end;
@@ -501,18 +517,29 @@ let rec unsafe_mapper : Ast_mapper.mapper =
           end
         | Pstr_primitive 
             ({pval_attributes; 
-              pval_type; pval_loc} as prim) 
+              pval_prim; 
+              pval_type;
+              pval_loc} as prim) 
           when Ast_attributes.process_external pval_attributes
           -> 
           let pval_type = self.typ self pval_type in 
+          let pval_prim = 
+            match pval_prim with 
+            | [ v] -> 
+              [ v; 
+                Ast_external_attributes.(
+                  to_string @@
+                  handle_attributes pval_type pval_attributes v)
+              ]
+            | _ -> Location.raise_errorf "only a single string is allowed in bs external" in
           {str with 
            pstr_desc = 
              Pstr_primitive
                {prim with
                 pval_type ; 
-                pval_attributes = 
-                  Ast_attributes.mk_bs_type ~loc:pval_loc pval_type
-                  :: pval_attributes }}
+                pval_prim;
+                pval_attributes 
+               }}
 
         | _ -> Ast_mapper.default_mapper.structure_item self str 
         end

diff --git a/jscomp/syntax/syntax.mllib b/jscomp/syntax/syntax.mllib
@@ -12,3 +12,4 @@ ast_structure
 ast_derive
 ast_signature
 ast_core_type
+ast_external_attributes
diff --git a/jscomp/test/poly_variant_test.mli b/jscomp/test/poly_variant_test.mli
@@ -5,7 +5,7 @@ external test_string_type : ([`on_closed | `on_open | `in_ [@bs.as "in"]]
                 [@bs.string]) -> int  = 
   "hey_string" [@@bs.call]
 
-external test_int_type : ([`on_closed | `on_open | `in_ [@bs.as "in"]]
+external test_int_type : ([`on_closed | `on_open [@bs.as 3] | `in_   ]
                 [@bs.int]) -> int  = 
   "hey_int" [@@bs.call]