Merge pull request #3869 from BuckleScript/snapshot_changes

snapshot changes and get back build_sorted.ml

Author: bobzhang

lib/4.02.3/bsb_helper.ml

@@ -4156,13 +4156,14 @@ type kind = Js | Bytecode | Native
 val deps_of_channel : in_channel -> string list
 
 
-
-val emit_d:  
+val emit_d: 
+  kind -> 
   Bsb_dir_index.t ->  
   string  option ->
   string ->
   string -> (* empty string means no mliast *)
   unit
+
 end = struct
 #1 "bsb_helper_depfile_gen.ml"
 (* Copyright (C) 2015-2016 Bloomberg Finance L.P.
@@ -4410,6 +4411,7 @@ let oc_intf
 
 
 let emit_d 
+  compilation_kind
   (index : Bsb_dir_index.t) 
   (namespace : string option) (mlast : string) (mliast : string) = 
   let data  =
@@ -4418,9 +4420,12 @@ let emit_d
   let buf = Ext_buffer.create 2048 in 
   let filename = 
       Ext_filename.new_extension mlast Literals.suffix_d in   
-  let lhs_suffix = Literals.suffix_cmj in   
-  let rhs_suffix = Literals.suffix_cmj in 
-  
+  let lhs_suffix, rhs_suffix =
+    match compilation_kind with
+    | Js       -> Literals.suffix_cmj, Literals.suffix_cmj
+    | Bytecode -> Literals.suffix_cmo, Literals.suffix_cmo
+    | Native   -> Literals.suffix_cmx, Literals.suffix_cmx 
+  in   
   oc_impl 
     mlast
     index 
@@ -4439,12 +4444,6 @@ let emit_d
   end;          
   write_file filename buf 
 
-
-
-
-
-
-
 end
 module Bsb_helper_main : sig 
 #1 "bsb_helper_main.mli"
@@ -4510,6 +4509,8 @@ end = struct
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
+let compilation_kind = ref Bsb_helper_depfile_gen.Js
+
 let hash : string ref = ref ""
 let batch_files = ref []
 let collect_file name =
@@ -4539,11 +4540,13 @@ let () =
   match !batch_files with
   | [x]
     ->  Bsb_helper_depfile_gen.emit_d
+          !compilation_kind
           (Bsb_dir_index.of_int !dev_group )          
           !namespace x ""
   | [y; x] (* reverse order *)
     -> 
     Bsb_helper_depfile_gen.emit_d
+      !compilation_kind
       (Bsb_dir_index.of_int !dev_group)
       !namespace x y
   | _ -> 

lib/4.02.3/bsdep.ml

@@ -39095,7 +39095,13 @@ let app_exp_mapper
          | 
            {pexp_desc = 
               (Pexp_ident {txt = Lident name;_ } 
-            | Pexp_constant (Const_string(name,None)))
+
+            | Pexp_constant (
+                            
+              Const_string              
+              
+              (name,None))
+            )
             ;
              pexp_loc}
            (* f##paint  *)
@@ -39125,7 +39131,11 @@ let app_exp_mapper
          | Some { args = [obj; {
              pexp_desc = 
                Pexp_ident {txt = Lident name}
-               | Pexp_constant (Const_string (name, None)); pexp_loc
+               | Pexp_constant (
+                            
+              Const_string              
+                         
+                  (name, None)); pexp_loc
            }
            ]
            }

lib/4.02.3/bsppx.ml

@@ -21201,7 +21201,13 @@ let app_exp_mapper
          | 
            {pexp_desc = 
               (Pexp_ident {txt = Lident name;_ } 
-            | Pexp_constant (Const_string(name,None)))
+
+            | Pexp_constant (
+                            
+              Const_string              
+              
+              (name,None))
+            )
             ;
              pexp_loc}
            (* f##paint  *)
@@ -21231,7 +21237,11 @@ let app_exp_mapper
          | Some { args = [obj; {
              pexp_desc = 
                Pexp_ident {txt = Lident name}
-               | Pexp_constant (Const_string (name, None)); pexp_loc
+               | Pexp_constant (
+                            
+              Const_string              
+                         
+                  (name, None)); pexp_loc
            }
            ]
            }

lib/4.02.3/unstable/bsb_native.ml

@@ -8548,26 +8548,82 @@ let cache : string Coll.t = Coll.create 0
 let to_list cb  =   
   Coll.to_list cache  cb 
 
+(* Some package managers will implement "postinstall" caches, that do not
+ * keep their build artifacts in the local node_modules. Similar to
+ * npm_config_prefix, bs_custom_resolution allows these to specify the
+ * exact location of build cache, but on a per-package basis. Implemented as
+ * environment lookup to avoid invasive changes to bsconfig and mandates. *)
+let custom_resolution = lazy
+  (match Sys.getenv "bs_custom_resolution" with
+  | exception Not_found  -> false
+  | "true"  -> true
+  | _ -> false)
+
+let pkg_name_as_variable package =
+  Bsb_pkg_types.to_string package
+  |> fun s -> Ext_string.split s '@'
+  |> String.concat ""
+  |> fun s -> Ext_string.split s '_'
+  |> String.concat "__"
+  |> fun s -> Ext_string.split s '/'
+  |> String.concat "__slash__"
+  |> fun s -> Ext_string.split s '.'
+  |> String.concat "__dot__"
+  |> fun s -> Ext_string.split s '-'
+  |> String.concat "_"
+
 (** TODO: collect all warnings and print later *)
 let resolve_bs_package ~cwd (package : t) =
-  match Coll.find_opt cache package with
-  | None ->
-    let result = resolve_bs_package_aux ~cwd package in
-    Bsb_log.info "@{<info>Package@} %a -> %s@." Bsb_pkg_types.print package result ;
-    Coll.add cache package result ;
-    result
-  | Some x
-    ->
-    let result = resolve_bs_package_aux ~cwd package in
-    if result <> x then
+  if Lazy.force custom_resolution then
+  begin
+    Bsb_log.info "@{<info>Using Custom Resolution@}@.";
+    let custom_pkg_loc = pkg_name_as_variable package ^ "__install" in
+    let custom_pkg_location = lazy (Sys.getenv custom_pkg_loc) in
+    match Lazy.force custom_pkg_location with
+    | exception Not_found ->
+        begin
+          Bsb_log.error
+            "@{<error>Custom resolution of package %s does not exist in var %s @}@."
+            (Bsb_pkg_types.to_string package)
+            custom_pkg_loc;
+          Bsb_exception.package_not_found ~pkg:package ~json:None
+        end
+    | path when not (Sys.file_exists path) ->
+        begin
+          Bsb_log.error
+            "@{<error>Custom resolution of package %s does not exist on disk: %s=%s @}@."
+            (Bsb_pkg_types.to_string package)
+            custom_pkg_loc
+            path;
+          Bsb_exception.package_not_found ~pkg:package ~json:None
+        end
+    | path ->
       begin
-        Bsb_log.warn
-          "@{<warning>Duplicated package:@} %a %s (chosen) vs %s in %s @." 
-            Bsb_pkg_types.print package x result cwd;
-      end;
-    x
-
-
+        Bsb_log.info
+          "@{<info>Custom Resolution of package %s in var %s found at %s@}@."
+          (Bsb_pkg_types.to_string package)
+          custom_pkg_loc
+          path;
+        path
+      end
+    end
+  else
+    match Coll.find_opt cache package with
+    | None ->
+      let result = resolve_bs_package_aux ~cwd package in
+      Bsb_log.info "@{<info>Package@} %a -> %s@." Bsb_pkg_types.print package result ;
+      Coll.add cache package result ;
+      result
+    | Some x
+      ->
+      let result = resolve_bs_package_aux ~cwd package in
+      if result <> x then
+        begin
+          Bsb_log.warn
+            "@{<warning>Duplicated package:@} %a %s (chosen) vs %s in %s @." 
+              Bsb_pkg_types.print package x result cwd;
+        end;
+      x
 
 
 (** The package does not need to be a bspackage

lib/4.02.3/unstable/js_compiler.ml

@@ -21082,7 +21082,13 @@ let app_exp_mapper
          | 
            {pexp_desc = 
               (Pexp_ident {txt = Lident name;_ } 
-            | Pexp_constant (Const_string(name,None)))
+
+            | Pexp_constant (
+                            
+              Const_string              
+              
+              (name,None))
+            )
             ;
              pexp_loc}
            (* f##paint  *)
@@ -21112,7 +21118,11 @@ let app_exp_mapper
          | Some { args = [obj; {
              pexp_desc = 
                Pexp_ident {txt = Lident name}
-               | Pexp_constant (Const_string (name, None)); pexp_loc
+               | Pexp_constant (
+                            
+              Const_string              
+                         
+                  (name, None)); pexp_loc
            }
            ]
            }
@@ -75490,7 +75500,7 @@ let primitive ppf (prim : Lam_primitive.t) = match prim with
   | Pmakeblock(tag, _, Mutable) -> fprintf ppf "makemutable %i" tag
   | Pfield (n, (Fld_module s | Fld_record s)) 
     -> fprintf ppf "field %s/%i" s n
-  | Pfield (n, Fld_na) 
+  | Pfield (n, _) 
     -> fprintf ppf "field %i" n
   | Pfield_computed -> 
     fprintf ppf "field_computed"
@@ -110495,11 +110505,18 @@ type default_case =
 let no_effects_const  = lazy true
 let has_effects_const = lazy false
 
+let is_nullary_variant x = 
+  match x with 
+  
+  |  [] -> true 
+  
+  | _ -> false
+
 let names_from_construct_pattern (pat: Typedtree.pattern) =
   let names_from_type_variant cstrs =
     let (consts, blocks) = List.fold_left
       (fun (consts, blocks) cstr ->
-        if cstr.Types.cd_args = []
+        if is_nullary_variant cstr.Types.cd_args 
         then (Ident.name cstr.Types.cd_id :: consts, blocks)
         else (consts, Ident.name cstr.Types.cd_id :: blocks))
       ([], []) cstrs in