From 4b654449d75bcdbfac0fe1e059acd7e88a11aad4 Mon Sep 17 00:00:00 2001 From: ELLIOTTCABLE Date: Mon, 6 Apr 2020 00:28:49 -0500 Subject: [PATCH] (- meta) Update lib/. Plz explain why this is checked into source-control ... =/ --- lib/4.06.1/bsb.ml | 2912 +++++++++++----------- lib/4.06.1/bsb_helper.ml | 26 +- lib/4.06.1/bsdep.ml | 155 +- lib/4.06.1/bsppx.ml | 155 +- lib/4.06.1/unstable/all_ounit_tests.ml | 40 +- lib/4.06.1/unstable/bsb_native.ml | 2912 +++++++++++----------- lib/4.06.1/unstable/bspack.ml | 4 + lib/4.06.1/unstable/js_compiler.ml | 186 +- lib/4.06.1/unstable/js_refmt_compiler.ml | 186 +- lib/4.06.1/unstable/native_ppx.ml | 155 +- lib/4.06.1/whole_compiler.ml | 186 +- 11 files changed, 3477 insertions(+), 3440 deletions(-) diff --git a/lib/4.06.1/bsb.ml b/lib/4.06.1/bsb.ml index 062b7bfb5f..eb25768bd9 100644 --- a/lib/4.06.1/bsb.ml +++ b/lib/4.06.1/bsb.ml @@ -141,11 +141,12 @@ let generators = "generators" let command = "command" let edge = "edge" let namespace = "namespace" +let _module = "module" let in_source = "in-source" +let suffix = "suffix" let warnings = "warnings" let number = "number" let error = "error" -let suffix = "suffix" let gentypeconfig = "gentypeconfig" let path = "path" let ignored_dirs = "ignored-dirs" @@ -4465,7 +4466,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -4604,7 +4607,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -5861,344 +5866,159 @@ let () = ) end -module Ext_buffer : sig -#1 "ext_buffer.mli" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(** Extensible buffers. - - This module implements buffers that automatically expand - as necessary. It provides accumulative concatenation of strings - in quasi-linear time (instead of quadratic time when strings are - concatenated pairwise). -*) - -(* BuckleScript customization: customized for efficient digest *) - -type t -(** The abstract type of buffers. *) - -val create : int -> t -(** [create n] returns a fresh buffer, initially empty. - The [n] parameter is the initial size of the internal byte sequence - that holds the buffer contents. That byte sequence is automatically - reallocated when more than [n] characters are stored in the buffer, - but shrinks back to [n] characters when [reset] is called. - For best performance, [n] should be of the same order of magnitude - as the number of characters that are expected to be stored in - the buffer (for instance, 80 for a buffer that holds one output - line). Nothing bad will happen if the buffer grows beyond that - limit, however. In doubt, take [n = 16] for instance. - If [n] is not between 1 and {!Sys.max_string_length}, it will - be clipped to that interval. *) +module Ext_color : sig +#1 "ext_color.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val contents : t -> string -(** Return a copy of the current contents of the buffer. - The buffer itself is unchanged. *) +type color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White -val length : t -> int -(** Return the number of characters currently contained in the buffer. *) +type style + = FG of color + | BG of color + | Bold + | Dim -val is_empty : t -> bool +(** Input is the tag for example `@{@}` return escape code *) +val ansi_of_tag : string -> string -val clear : t -> unit -(** Empty the buffer. *) +val reset_lit : string +end = struct +#1 "ext_color.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val add_char : t -> char -> unit -(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) -val add_string : t -> string -> unit -(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) -val add_bytes : t -> bytes -> unit -(** [add_string b s] appends the string [s] at the end of the buffer [b]. - @since 4.02 *) -val add_substring : t -> string -> int -> int -> unit -(** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in string [s] and appends them at the end of the buffer [b]. *) +type color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White -val add_subbytes : t -> bytes -> int -> int -> unit -(** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. - @since 4.02 *) +type style + = FG of color + | BG of color + | Bold + | Dim -val add_buffer : t -> t -> unit -(** [add_buffer b1 b2] appends the current contents of buffer [b2] - at the end of buffer [b1]. [b2] is not modified. *) -val add_channel : t -> in_channel -> int -> unit -(** [add_channel b ic n] reads exactly [n] character from the - input channel [ic] and stores them at the end of buffer [b]. - Raise [End_of_file] if the channel contains fewer than [n] - characters. *) +let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" -val output_buffer : out_channel -> t -> unit -(** [output_buffer oc b] writes the current contents of buffer [b] - on the output channel [oc]. *) +let code_of_style = function + | FG Black -> "30" + | FG Red -> "31" + | FG Green -> "32" + | FG Yellow -> "33" + | FG Blue -> "34" + | FG Magenta -> "35" + | FG Cyan -> "36" + | FG White -> "37" + + | BG Black -> "40" + | BG Red -> "41" + | BG Green -> "42" + | BG Yellow -> "43" + | BG Blue -> "44" + | BG Magenta -> "45" + | BG Cyan -> "46" + | BG White -> "47" -val digest : t -> Digest.t + | Bold -> "1" + | Dim -> "2" -val not_equal : - t -> - string -> - bool -val add_int_1 : - t -> int -> unit -val add_int_2 : - t -> int -> unit +(** TODO: add more styles later *) +let style_of_tag s = match s with + | "error" -> [Bold; FG Red] + | "warning" -> [Bold; FG Magenta] + | "info" -> [Bold; FG Yellow] + | "dim" -> [Dim] + | "filename" -> [FG Cyan] + | _ -> [] -val add_int_3 : - t -> int -> unit +let ansi_of_tag s = + let l = style_of_tag s in + let s = String.concat ";" (Ext_list.map l code_of_style) in + "\x1b[" ^ s ^ "m" -val add_int_4 : - t -> int -> unit -val add_string_char : - t -> - string -> - char -> - unit -val add_char_string : - t -> - char -> - string -> - unit -end = struct -#1 "ext_buffer.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) +let reset_lit = "\x1b[0m" -(* Extensible buffers *) - -type t = - {mutable buffer : bytes; - mutable position : int; - mutable length : int; - initial_buffer : bytes} - -let create n = - let n = if n < 1 then 1 else n in - - let n = if n > Sys.max_string_length then Sys.max_string_length else n in - - let s = Bytes.create n in - {buffer = s; position = 0; length = n; initial_buffer = s} - -let contents b = Bytes.sub_string b.buffer 0 b.position -let to_bytes b = Bytes.sub b.buffer 0 b.position - -let sub b ofs len = - if ofs < 0 || len < 0 || ofs > b.position - len - then invalid_arg "Ext_buffer.sub" - else Bytes.sub_string b.buffer ofs len - - -let blit src srcoff dst dstoff len = - if len < 0 || srcoff < 0 || srcoff > src.position - len - || dstoff < 0 || dstoff > (Bytes.length dst) - len - then invalid_arg "Ext_buffer.blit" - else - Bytes.unsafe_blit src.buffer srcoff dst dstoff len - -let length b = b.position -let is_empty b = b.position = 0 -let clear b = b.position <- 0 - -let reset b = - b.position <- 0; b.buffer <- b.initial_buffer; - b.length <- Bytes.length b.buffer - -let resize b more = - let len = b.length in - let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - else failwith "Ext_buffer.add: cannot grow buffer" - end; - - let new_buffer = Bytes.create !new_len in - (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. *) - Bytes.blit b.buffer 0 new_buffer 0 b.position; - b.buffer <- new_buffer; - b.length <- !new_len ; - assert (b.position + more <= b.length) - -let add_char b c = - let pos = b.position in - if pos >= b.length then resize b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - -let add_substring b s offset len = - if offset < 0 || len < 0 || offset > String.length s - len - then invalid_arg "Ext_buffer.add_substring/add_subbytes"; - let new_position = b.position + len in - if new_position > b.length then resize b len; - Ext_bytes.unsafe_blit_string s offset b.buffer b.position len; - b.position <- new_position - - -let add_subbytes b s offset len = - add_substring b (Bytes.unsafe_to_string s) offset len - -let add_string b s = - let len = String.length s in - let new_position = b.position + len in - if new_position > b.length then resize b len; - Ext_bytes.unsafe_blit_string s 0 b.buffer b.position len; - b.position <- new_position - -(* TODO: micro-optimzie *) -let add_string_char b s c = - let s_len = String.length s in - let len = s_len + 1 in - let new_position = b.position + len in - if new_position > b.length then resize b len; - let b_buffer = b.buffer in - Ext_bytes.unsafe_blit_string s 0 b_buffer b.position s_len; - Bytes.unsafe_set b_buffer (new_position - 1) c; - b.position <- new_position - -let add_char_string b c s = - let s_len = String.length s in - let len = s_len + 1 in - let new_position = b.position + len in - if new_position > b.length then resize b len; - let b_buffer = b.buffer in - let b_position = b.position in - Bytes.unsafe_set b_buffer b_position c ; - Ext_bytes.unsafe_blit_string s 0 b_buffer (b_position + 1) s_len; - b.position <- new_position - - -let add_bytes b s = add_string b (Bytes.unsafe_to_string s) - -let add_buffer b bs = - add_subbytes b bs.buffer 0 bs.position - -let add_channel b ic len = - if len < 0 - - || len > Sys.max_string_length - - then (* PR#5004 *) - invalid_arg "Ext_buffer.add_channel"; - if b.position + len > b.length then resize b len; - really_input ic b.buffer b.position len; - b.position <- b.position + len - -let output_buffer oc b = - output oc b.buffer 0 b.position - -external unsafe_string: bytes -> int -> int -> Digest.t = "caml_md5_string" - -let digest b = - unsafe_string - b.buffer 0 b.position - -let rec not_equal_aux (b : bytes) (s : string) i len = - if i >= len then false - else - (Bytes.unsafe_get b i - <> - String.unsafe_get s i ) - || not_equal_aux b s (i + 1) len - -(** avoid a large copy *) -let not_equal (b : t) (s : string) = - let b_len = b.position in - let s_len = String.length s in - b_len <> s_len - || not_equal_aux b.buffer s 0 s_len - - -(** - It could be one byte, two bytes, three bytes and four bytes - TODO: inline for better performance -*) -let add_int_1 (b : t ) (x : int ) = - let c = (Char.unsafe_chr (x land 0xff)) in - let pos = b.position in - if pos >= b.length then resize b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - -let add_int_2 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let pos = b.position in - if pos + 1 >= b.length then resize b 2; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - b.position <- pos + 2 - -let add_int_3 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in - let pos = b.position in - if pos + 2 >= b.length then resize b 3; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - Bytes.unsafe_set b_buffer (pos + 2) c3; - b.position <- pos + 3 - - -let add_int_4 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in - let c4 = (Char.unsafe_chr (x lsr 24 land 0xff)) in - let pos = b.position in - if pos + 3 >= b.length then resize b 4; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - Bytes.unsafe_set b_buffer (pos + 2) c3; - Bytes.unsafe_set b_buffer (pos + 3) c4; - b.position <- pos + 4 end -module Ext_filename : sig -#1 "ext_filename.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. +module Bsb_log : sig +#1 "bsb_log.mli" +(* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6223,69 +6043,31 @@ module Ext_filename : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +val setup : unit -> unit +type level = + | Debug + | Info + | Warn + | Error +val log_level : level ref -(* TODO: - Change the module name, this code is not really an extension of the standard - library but rather specific to JS Module name convention. -*) - - - - - -(** An extension module to calculate relative path follow node/npm style. - TODO : this short name will have to change upon renaming the file. -*) - -val is_dir_sep : - char -> bool - -val maybe_quote: - string -> - string - -val chop_extension_maybe: - string -> - string - -(* return an empty string if no extension found *) -val get_extension_maybe: - string -> - string - - -val new_extension: - string -> - string -> - string - -val chop_all_extensions_maybe: - string -> - string - -(* OCaml specific abstraction*) -val module_name: - string -> - string - - - +type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a -type module_info = { - module_name : string ; - case : bool; -} +type 'a log = ('a, Format.formatter, unit) format -> 'a +val verbose : unit -> unit +val debug : 'a log +val info : 'a log +val warn : 'a log +val error : 'a log +val info_args : string array -> unit -val as_module: - basename:string -> - module_info option end = struct -#1 "ext_filename.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. +#1 "bsb_log.ml" +(* Copyright (C) 2017- Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6311,7 +6093,542 @@ end = struct - +let ninja_ansi_forced = lazy + (try Sys.getenv "NINJA_ANSI_FORCED" with + Not_found ->"" + ) +let color_enabled = lazy (Unix.isatty Unix.stdout) + +(* same logic as [ninja.exe] *) +let get_color_enabled () = + let colorful = + match ninja_ansi_forced with + | lazy "1" -> true + | lazy ("0" | "false") -> false + | _ -> + Lazy.force color_enabled in + colorful + + + +let color_functions : Format.formatter_tag_functions = { + mark_open_tag = (fun s -> if get_color_enabled () then Ext_color.ansi_of_tag s else Ext_string.empty) ; + mark_close_tag = (fun _ -> if get_color_enabled () then Ext_color.reset_lit else Ext_string.empty); + print_open_tag = (fun _ -> ()); + print_close_tag = (fun _ -> ()) +} + +let set_color ppf = + Format.pp_set_formatter_tag_functions ppf color_functions + + +let setup () = + begin + Format.pp_set_mark_tags Format.std_formatter true ; + Format.pp_set_mark_tags Format.err_formatter true; + Format.pp_set_formatter_tag_functions + Format.std_formatter color_functions; + Format.pp_set_formatter_tag_functions + Format.err_formatter color_functions + end + +type level = + | Debug + | Info + | Warn + | Error + +let int_of_level (x : level) = + match x with + | Debug -> 0 + | Info -> 1 + | Warn -> 2 + | Error -> 3 + +let log_level = ref Warn + +let verbose () = + log_level := Debug +let dfprintf level fmt = + if int_of_level level >= int_of_level !log_level then + Format.fprintf fmt + else Format.ifprintf fmt + +type 'a fmt = + Format.formatter -> ('a, Format.formatter, unit) format -> 'a +type 'a log = + ('a, Format.formatter, unit) format -> 'a + +let debug fmt = dfprintf Debug Format.std_formatter fmt +let info fmt = dfprintf Info Format.std_formatter fmt +let warn fmt = dfprintf Warn Format.err_formatter fmt +let error fmt = dfprintf Error Format.err_formatter fmt + + +let info_args (args : string array) = + if int_of_level Info >= int_of_level !log_level then + begin + for i = 0 to Array.length args - 1 do + Format.pp_print_string Format.std_formatter (Array.unsafe_get args i) ; + Format.pp_print_string Format.std_formatter Ext_string.single_space; + done ; + Format.pp_print_newline Format.std_formatter () + end + else () + + +end +module Ext_buffer : sig +#1 "ext_buffer.mli" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Extensible buffers. + + This module implements buffers that automatically expand + as necessary. It provides accumulative concatenation of strings + in quasi-linear time (instead of quadratic time when strings are + concatenated pairwise). +*) + +(* BuckleScript customization: customized for efficient digest *) + +type t +(** The abstract type of buffers. *) + +val create : int -> t +(** [create n] returns a fresh buffer, initially empty. + The [n] parameter is the initial size of the internal byte sequence + that holds the buffer contents. That byte sequence is automatically + reallocated when more than [n] characters are stored in the buffer, + but shrinks back to [n] characters when [reset] is called. + For best performance, [n] should be of the same order of magnitude + as the number of characters that are expected to be stored in + the buffer (for instance, 80 for a buffer that holds one output + line). Nothing bad will happen if the buffer grows beyond that + limit, however. In doubt, take [n = 16] for instance. + If [n] is not between 1 and {!Sys.max_string_length}, it will + be clipped to that interval. *) + +val contents : t -> string +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + +val length : t -> int +(** Return the number of characters currently contained in the buffer. *) + +val is_empty : t -> bool + +val clear : t -> unit +(** Empty the buffer. *) + + +val add_char : t -> char -> unit +(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) + +val add_string : t -> string -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + +val add_bytes : t -> bytes -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. + @since 4.02 *) + +val add_substring : t -> string -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in string [s] and appends them at the end of the buffer [b]. *) + +val add_subbytes : t -> bytes -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. + @since 4.02 *) + +val add_buffer : t -> t -> unit +(** [add_buffer b1 b2] appends the current contents of buffer [b2] + at the end of buffer [b1]. [b2] is not modified. *) + +val add_channel : t -> in_channel -> int -> unit +(** [add_channel b ic n] reads exactly [n] character from the + input channel [ic] and stores them at the end of buffer [b]. + Raise [End_of_file] if the channel contains fewer than [n] + characters. *) + +val output_buffer : out_channel -> t -> unit +(** [output_buffer oc b] writes the current contents of buffer [b] + on the output channel [oc]. *) + +val digest : t -> Digest.t + +val not_equal : + t -> + string -> + bool + +val add_int_1 : + t -> int -> unit + +val add_int_2 : + t -> int -> unit + +val add_int_3 : + t -> int -> unit + +val add_int_4 : + t -> int -> unit + +val add_string_char : + t -> + string -> + char -> + unit + +val add_char_string : + t -> + char -> + string -> + unit +end = struct +#1 "ext_buffer.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Extensible buffers *) + +type t = + {mutable buffer : bytes; + mutable position : int; + mutable length : int; + initial_buffer : bytes} + +let create n = + let n = if n < 1 then 1 else n in + + let n = if n > Sys.max_string_length then Sys.max_string_length else n in + + let s = Bytes.create n in + {buffer = s; position = 0; length = n; initial_buffer = s} + +let contents b = Bytes.sub_string b.buffer 0 b.position +let to_bytes b = Bytes.sub b.buffer 0 b.position + +let sub b ofs len = + if ofs < 0 || len < 0 || ofs > b.position - len + then invalid_arg "Ext_buffer.sub" + else Bytes.sub_string b.buffer ofs len + + +let blit src srcoff dst dstoff len = + if len < 0 || srcoff < 0 || srcoff > src.position - len + || dstoff < 0 || dstoff > (Bytes.length dst) - len + then invalid_arg "Ext_buffer.blit" + else + Bytes.unsafe_blit src.buffer srcoff dst dstoff len + +let length b = b.position +let is_empty b = b.position = 0 +let clear b = b.position <- 0 + +let reset b = + b.position <- 0; b.buffer <- b.initial_buffer; + b.length <- Bytes.length b.buffer + +let resize b more = + let len = b.length in + let new_len = ref len in + while b.position + more > !new_len do new_len := 2 * !new_len done; + + if !new_len > Sys.max_string_length then begin + if b.position + more <= Sys.max_string_length + then new_len := Sys.max_string_length + else failwith "Ext_buffer.add: cannot grow buffer" + end; + + let new_buffer = Bytes.create !new_len in + (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in + this tricky function that is slow anyway. *) + Bytes.blit b.buffer 0 new_buffer 0 b.position; + b.buffer <- new_buffer; + b.length <- !new_len ; + assert (b.position + more <= b.length) + +let add_char b c = + let pos = b.position in + if pos >= b.length then resize b 1; + Bytes.unsafe_set b.buffer pos c; + b.position <- pos + 1 + +let add_substring b s offset len = + if offset < 0 || len < 0 || offset > String.length s - len + then invalid_arg "Ext_buffer.add_substring/add_subbytes"; + let new_position = b.position + len in + if new_position > b.length then resize b len; + Ext_bytes.unsafe_blit_string s offset b.buffer b.position len; + b.position <- new_position + + +let add_subbytes b s offset len = + add_substring b (Bytes.unsafe_to_string s) offset len + +let add_string b s = + let len = String.length s in + let new_position = b.position + len in + if new_position > b.length then resize b len; + Ext_bytes.unsafe_blit_string s 0 b.buffer b.position len; + b.position <- new_position + +(* TODO: micro-optimzie *) +let add_string_char b s c = + let s_len = String.length s in + let len = s_len + 1 in + let new_position = b.position + len in + if new_position > b.length then resize b len; + let b_buffer = b.buffer in + Ext_bytes.unsafe_blit_string s 0 b_buffer b.position s_len; + Bytes.unsafe_set b_buffer (new_position - 1) c; + b.position <- new_position + +let add_char_string b c s = + let s_len = String.length s in + let len = s_len + 1 in + let new_position = b.position + len in + if new_position > b.length then resize b len; + let b_buffer = b.buffer in + let b_position = b.position in + Bytes.unsafe_set b_buffer b_position c ; + Ext_bytes.unsafe_blit_string s 0 b_buffer (b_position + 1) s_len; + b.position <- new_position + + +let add_bytes b s = add_string b (Bytes.unsafe_to_string s) + +let add_buffer b bs = + add_subbytes b bs.buffer 0 bs.position + +let add_channel b ic len = + if len < 0 + + || len > Sys.max_string_length + + then (* PR#5004 *) + invalid_arg "Ext_buffer.add_channel"; + if b.position + len > b.length then resize b len; + really_input ic b.buffer b.position len; + b.position <- b.position + len + +let output_buffer oc b = + output oc b.buffer 0 b.position + +external unsafe_string: bytes -> int -> int -> Digest.t = "caml_md5_string" + +let digest b = + unsafe_string + b.buffer 0 b.position + +let rec not_equal_aux (b : bytes) (s : string) i len = + if i >= len then false + else + (Bytes.unsafe_get b i + <> + String.unsafe_get s i ) + || not_equal_aux b s (i + 1) len + +(** avoid a large copy *) +let not_equal (b : t) (s : string) = + let b_len = b.position in + let s_len = String.length s in + b_len <> s_len + || not_equal_aux b.buffer s 0 s_len + + +(** + It could be one byte, two bytes, three bytes and four bytes + TODO: inline for better performance +*) +let add_int_1 (b : t ) (x : int ) = + let c = (Char.unsafe_chr (x land 0xff)) in + let pos = b.position in + if pos >= b.length then resize b 1; + Bytes.unsafe_set b.buffer pos c; + b.position <- pos + 1 + +let add_int_2 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let pos = b.position in + if pos + 1 >= b.length then resize b 2; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + b.position <- pos + 2 + +let add_int_3 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in + let pos = b.position in + if pos + 2 >= b.length then resize b 3; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + Bytes.unsafe_set b_buffer (pos + 2) c3; + b.position <- pos + 3 + + +let add_int_4 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in + let c4 = (Char.unsafe_chr (x lsr 24 land 0xff)) in + let pos = b.position in + if pos + 3 >= b.length then resize b 4; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + Bytes.unsafe_set b_buffer (pos + 2) c3; + Bytes.unsafe_set b_buffer (pos + 3) c4; + b.position <- pos + 4 + + + + +end +module Ext_filename : sig +#1 "ext_filename.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + + + + +(* TODO: + Change the module name, this code is not really an extension of the standard + library but rather specific to JS Module name convention. +*) + + + + + +(** An extension module to calculate relative path follow node/npm style. + TODO : this short name will have to change upon renaming the file. +*) + +val is_dir_sep : + char -> bool + +val maybe_quote: + string -> + string + +val chop_extension_maybe: + string -> + string + +(* return an empty string if no extension found *) +val get_extension_maybe: + string -> + string + + +val new_extension: + string -> + string -> + string + +val chop_all_extensions_maybe: + string -> + string + +(* OCaml specific abstraction*) +val module_name: + string -> + string + + + + +type module_info = { + module_name : string ; + case : bool; +} + + + +val as_module: + basename:string -> + module_info option +end = struct +#1 "ext_filename.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + + + let is_dir_sep_unix c = c = '/' let is_dir_sep_win_cygwin c = c = '/' || c = '\\' || c = ':' @@ -6453,198 +6770,17 @@ let as_module ~basename = | Invalid -> None | Upper -> Some {module_name = Ext_string.capitalize_sub name i; case = true} - | Lower -> - Some {module_name = Ext_string.capitalize_sub name i; case = false} - else - search_dot (i - 1) name name_len in - let name_len = String.length basename in - search_dot (name_len - 1) basename name_len - -end -module Ext_namespace : sig -#1 "ext_namespace.mli" -(* Copyright (C) 2017- Authors of BuckleScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val make : ?ns:string -> string -> string -(** [make ~ns:"Ns" "a"] A typical example would return "a-Ns" Note the namespace - comes from the output of [namespace_of_package_name] *) - -val try_split_module_name : string -> (string * string) option - -val change_ext_ns_suffix : string -> string -> string - -type file_kind = Upper_js | Upper_bs | Little_js | Little_bs - -val js_name_of_modulename : string -> file_kind -> string -(** Predicts the JavaScript filename for a given (possibly namespaced) module- - name; i.e. [js_name_of_modulename "AA-Ns" Little_bs] would produce - ["aA.bs.js"]. *) - -val is_valid_npm_package_name : string -> bool - -val namespace_of_package_name : string -> string - -end = struct -#1 "ext_namespace.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Note the build system should check the validity of filenames espeically, it - should not contain '-' *) -let ns_sep_char = '-' -let ns_sep = "-" - -let make ?ns cunit = - match ns with - | None -> cunit - | Some ns -> cunit ^ ns_sep ^ ns - - -(** Starting from the end, search for [ns_sep_char]. Returns the index, if - found, or [-1] if [ns_sep_char] is not found before reaching a - directory-separator. *) -let rec rindex_rec s i = - if i < 0 then i - else - let char = String.unsafe_get s i in - if Ext_filename.is_dir_sep char then -1 - else if char = ns_sep_char then i - else rindex_rec s (i - 1) - - -(* Note we have to output uncapitalized file Name, or at least be consistent, - since by reading cmi file on Case insensitive OS, we don't really know - whether it is `list.cmi` or `List.cmi`, so that `require(./list.js)` or - `require(./List.js)`. Relevant issues: #1609, #913 - - #1933 when removing ns suffix, don't pass the bound of basename - - FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = - let i = rindex_rec name (String.length name - 1) in - if i < 0 then name ^ ext else String.sub name 0 i ^ ext - - -let try_split_module_name name = - let len = String.length name in - let i = rindex_rec name (len - 1) in - if i < 0 then None - else Some (String.sub name (i + 1) (len - i - 1), String.sub name 0 i) - - -type file_kind = Upper_js | Upper_bs | Little_js | Little_bs - -let js_name_of_modulename s little = - match little with - | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js - | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js - - -(** https://docs.npmjs.com/files/package.json - - Some rules: - - - The name must be less than or equal to 214 characters. This includes the - scope for scoped packages. - - The name can't start with a dot or an underscore. - - New packages must not have uppercase letters in the name. - - The name ends up being part of a URL, an argument on the command line, and - a folder name. Therefore, the name can't contain any non-URL-safe - characters. - - TODO: handle cases like '\@angular/core'. its directory structure is like: - - {[ - @angular - |-------- core - ]} *) -let is_valid_npm_package_name (s : string) = - let len = String.length s in - len <= 214 (* magic number forced by npm *) - && len > 0 - && - match String.unsafe_get s 0 with - | 'a' .. 'z' | '@' -> - Ext_string.for_all_from s 1 (fun x -> - match x with - | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true - | _ -> false) - | _ -> false - - -let namespace_of_package_name (s : string) : string = - let len = String.length s in - let buf = Ext_buffer.create len in - let add capital ch = - Ext_buffer.add_char buf (if capital then Char.uppercase_ascii ch else ch) - in - let rec aux capital off len = - if off >= len then () - else - let ch = String.unsafe_get s off in - match ch with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> - add capital ch; - aux false (off + 1) len - | '/' | '-' -> aux true (off + 1) len - | _ -> aux capital (off + 1) len - in - aux true 0 len; - Ext_buffer.contents buf - + | Lower -> + Some {module_name = Ext_string.capitalize_sub name i; case = false} + else + search_dot (i - 1) name name_len in + let name_len = String.length basename in + search_dot (name_len - 1) basename name_len + end -module Bsb_package_specs : sig -#1 "bsb_package_specs.mli" -(* Copyright (C) 2017 Authors of BuckleScript +module Ext_namespace : sig +#1 "ext_namespace.mli" +(* Copyright (C) 2017- Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6668,24 +6804,31 @@ module Bsb_package_specs : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t +val make : ?ns:string -> string -> string +(** [make ~ns:"Ns" "a"] A typical example would return "a-Ns" Note the namespace + comes from the output of [namespace_of_package_name] *) -val default_package_specs : t +val try_split_module_name : string -> (string * string) option -val from_json : Ext_json_types.t -> t +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) -val get_list_of_output_js : t -> bool -> string -> string list +type file_kind = Upper_js | Upper_bs | Little_js | Little_bs -val package_flag_of_package_specs : t -> string -> string -(** Sample output: +val js_name_of_modulename : string -> file_kind -> string +(** Predicts the JavaScript filename for a given (possibly namespaced) module- + name; i.e. [js_name_of_modulename "AA-Ns" Little_bs] would produce + ["aA.bs.js"]. *) - {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) +val is_valid_npm_package_name : string -> bool -val list_dirs_by : t -> (string -> unit) -> unit +val namespace_of_package_name : string -> string end = struct -#1 "bsb_package_specs.ml" -(* Copyright (C) 2017 Authors of BuckleScript +#1 "ext_namespace.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6709,200 +6852,121 @@ 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 ( // ) = Ext_path.combine - -(* TODO: sync up with {!Js_package_info.module_system} *) -type format = NodeJS | Es6 | Es6_global - -type spec = { format : format; in_source : bool } - -module Spec_set = Set.Make (struct - type t = spec - let compare = Pervasives.compare -end) - -type t = Spec_set.t - -let bad_module_format_message_exn ~loc format = - Bsb_exception.errorf ~loc - "package-specs: `%s` isn't a valid output module format. It has to be one \ - of: %s, %s or %s" - format Literals.commonjs Literals.es6 Literals.es6_global - - -let supported_format (x : string) loc = - if x = Literals.commonjs then NodeJS - else if x = Literals.es6 then Es6 - else if x = Literals.es6_global then Es6_global - else bad_module_format_message_exn ~loc x - - -let string_of_format (x : format) = - match x with - | NodeJS -> Literals.commonjs - | Es6 -> Literals.es6 - | Es6_global -> Literals.es6_global - - -let prefix_of_format (x : format) = - match x with - | NodeJS -> Bsb_config.lib_js - | Es6 -> Bsb_config.lib_es6 - | Es6_global -> Bsb_config.lib_es6_global - - -let rec from_array (arr : Ext_json_types.t array) : Spec_set.t = - let spec = ref Spec_set.empty in - let has_in_source = ref false in - Ext_array.iter arr (fun x -> - let result = from_json_single x in - if result.in_source then - if not !has_in_source then has_in_source := true - else - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: we've detected two module formats that are both \ - configured to be in-source."; - spec := Spec_set.add result !spec); - !spec - - -(* TODO: FIXME: better API without mutating *) -and from_json_single (x : Ext_json_types.t) : spec = - match x with - | Str { str = format; loc } -> - { format = supported_format format loc; in_source = false } - | Obj { map; loc } -> ( - match Map_string.find_exn map "module" with - | Str { str = format } -> - let in_source = - match Map_string.find_opt map Bsb_build_schemas.in_source with - | Some (True _) -> true - | Some _ | None -> false - in - { format = supported_format format loc; in_source } - | Arr _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, `module` \ - field should be a string, not an array. If you want to pass \ - multiple module specs, try turning package-specs into an array of \ - objects (or strings) instead." - | _ -> - Bsb_exception.errorf ~loc - "package-specs: the `module` field of the configuration object \ - should be a string." - | exception _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, the `module` \ - field is mandatory." ) - | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: we expect either a string or an object." - - -let from_json (x : Ext_json_types.t) : Spec_set.t = - match x with - | Arr { content; _ } -> from_array content - | _ -> Spec_set.singleton (from_json_single x) - +(* Note the build system should check the validity of filenames espeically, it + should not contain '-' *) +let ns_sep_char = '-' +let ns_sep = "-" -let bs_package_output = "-bs-package-output" +let make ?ns cunit = + match ns with + | None -> cunit + | Some ns -> cunit ^ ns_sep ^ ns -(** Assume input is valid - {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) -let package_flag ({ format; in_source } : spec) dir = - Ext_string.inter2 bs_package_output - (Ext_string.concat3 (string_of_format format) Ext_string.single_colon - (if in_source then dir else prefix_of_format format // dir)) +(** Starting from the end, search for [ns_sep_char]. Returns the index, if + found, or [-1] if [ns_sep_char] is not found before reaching a + directory-separator. *) +let rec rindex_rec s i = + if i < 0 then i + else + let char = String.unsafe_get s i in + if Ext_filename.is_dir_sep char then -1 + else if char = ns_sep_char then i + else rindex_rec s (i - 1) -let package_flag_of_package_specs (package_specs : t) (dirname : string) : - string = - Spec_set.fold - (fun format acc -> Ext_string.inter2 acc (package_flag format dirname)) - package_specs Ext_string.empty +(* Note we have to output uncapitalized file Name, or at least be consistent, + since by reading cmi file on Case insensitive OS, we don't really know + whether it is `list.cmi` or `List.cmi`, so that `require(./list.js)` or + `require(./List.js)`. Relevant issues: #1609, #913 + #1933 when removing ns suffix, don't pass the bound of basename -let default_package_specs = - Spec_set.singleton { format = NodeJS; in_source = false } + FIXME: micro-optimizaiton *) +let replace_namespace_with_extension ~name ~ext = + let i = rindex_rec name (String.length name - 1) in + if i < 0 then name ^ ext else String.sub name 0 i ^ ext -(** [get_list_of_output_js specs true "src/hi/hello"] *) -let get_list_of_output_js (package_specs : Spec_set.t) (bs_suffix : bool) - (output_file_sans_extension : string) = - Spec_set.fold - (fun (spec : spec) acc -> - let basename = - Ext_namespace.change_ext_ns_suffix output_file_sans_extension - (if bs_suffix then Literals.suffix_bs_js else Literals.suffix_js) - in - ( Bsb_config.proj_rel - @@ - if spec.in_source then basename - else prefix_of_format spec.format // basename ) - :: acc) - package_specs [] +let try_split_module_name name = + let len = String.length name in + let i = rindex_rec name (len - 1) in + if i < 0 then None + else Some (String.sub name (i + 1) (len - i - 1), String.sub name 0 i) -let list_dirs_by (package_specs : Spec_set.t) (f : string -> unit) = - Spec_set.iter - (fun (spec : spec) -> - if not spec.in_source then f (prefix_of_format spec.format)) - package_specs +type file_kind = Upper_js | Upper_bs | Little_js | Little_bs -end -module Bsc_warnings -= struct -#1 "bsc_warnings.ml" -(* Copyright (C) 2020- Authors of BuckleScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 +let js_name_of_modulename s little = + match little with + | Little_js -> + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js + | Little_bs -> + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +(** https://docs.npmjs.com/files/package.json + Some rules: -(** - See the meanings of the warning codes here: https://caml.inria.fr/pub/docs/manual-ocaml/comp.html#sec281 + - The name must be less than or equal to 214 characters. This includes the + scope for scoped packages. + - The name can't start with a dot or an underscore. + - New packages must not have uppercase letters in the name. + - The name ends up being part of a URL, an argument on the command line, and + a folder name. Therefore, the name can't contain any non-URL-safe + characters. - - 30 Two labels or constructors of the same name are defined in two mutually recursive types. - - 40 Constructor or label name used out of scope. + TODO: handle cases like '\@angular/core'. its directory structure is like: - - 6 Label omitted in function application. - - 7 Method overridden. - - 9 Missing fields in a record pattern. (*Not always desired, in some cases need [@@@warning "+9"] *) - - 27 Innocuous unused variable: unused variable that is not bound with let nor as, and doesn’t start with an underscore (_) character. - - 29 Unescaped end-of-line in a string constant (non-portable code). - - 32 .. 39 Unused blabla - - 44 Open statement shadows an already defined identifier. - - 45 Open statement shadows an already defined label or constructor. - - 48 Implicit elimination of optional arguments. https://caml.inria.fr/mantis/view.php?id=6352 - - 101 (bsb-specific) unsafe polymorphic comparison. -*) -let defaults_w = "-30-40+6+7+27+32..39+44+45+101" -let defaults_warn_error = "-a+5+101";; + {[ + @angular + |-------- core + ]} *) +let is_valid_npm_package_name (s : string) = + let len = String.length s in + len <= 214 (* magic number forced by npm *) + && len > 0 + && + match String.unsafe_get s 0 with + | 'a' .. 'z' | '@' -> + Ext_string.for_all_from s 1 (fun x -> + match x with + | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true + | _ -> false) + | _ -> false + + +let namespace_of_package_name (s : string) : string = + let len = String.length s in + let buf = Ext_buffer.create len in + let add capital ch = + Ext_buffer.add_char buf (if capital then Char.uppercase_ascii ch else ch) + in + let rec aux capital off len = + if off >= len then () + else + let ch = String.unsafe_get s off in + match ch with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> + add capital ch; + aux false (off + 1) len + | '/' | '-' -> aux true (off + 1) len + | _ -> aux capital (off + 1) len + in + aux true 0 len; + Ext_buffer.contents buf end -module Bsb_warning : sig -#1 "bsb_warning.mli" +module Bsb_package_specs : sig +#1 "bsb_package_specs.mli" (* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify @@ -6927,28 +6991,25 @@ module Bsb_warning : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +type t +val default_package_specs : t +val from_json : Ext_json_types.t -> t -type t - -(** Extra work is need to make merlin happy *) -val to_merlin_string : t -> string +val get_list_of_output_js : t -> string -> string list +val extract_in_source_bs_suffixes : t -> string list +val package_flag_of_package_specs : t -> string -> string +(** Sample output: -val from_map : Ext_json_types.t Map_string.t -> t + {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) -(** [to_bsb_string not_dev warning] -*) -val to_bsb_string : - toplevel:bool -> - t -> - string +val list_dirs_by : t -> (string -> unit) -> unit -val use_default : t end = struct -#1 "bsb_warning.ml" +#1 "bsb_package_specs.ml" (* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify @@ -6973,199 +7034,204 @@ 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 ( // ) = Ext_path.combine -type warning_error = - | Warn_error_false - (* default [false] to make our changes non-intrusive *) - | Warn_error_true - | Warn_error_number of string +(* TODO: sync up with {!Js_package_info.module_system} *) +type format = NodeJS | Es6 | Es6_global -type t0 = { - number : string option; - error : warning_error -} +type spec = { format : format; in_source : bool; suffix : string } -type nonrec t = t0 option +module Spec_set = Set.Make (struct + type t = spec + let compare = Pervasives.compare +end) -let use_default = None +type t = Spec_set.t -let prepare_warning_concat ~(beg : bool) s = - let s = Ext_string.trim s in - if s = "" then s - else - match s.[0] with - | '0' .. '9' -> if beg then "-w +" ^ s else "+" ^ s - | 'a' .. 'z' -> - if beg then "-w " ^ s else "+" ^ s - | _ -> - if beg then "-w " ^ s else s +let bad_module_format_message_exn ~loc format = + Bsb_exception.errorf ~loc + "package-specs: `%s` isn't a valid output module format. It has to be one \ + of: %s, %s or %s" + format Literals.commonjs Literals.es6 Literals.es6_global -let to_merlin_string x = - "-w " ^ Bsc_warnings.defaults_w - ^ - (match x with - | Some {number =None} - | None -> Ext_string.empty - | Some {number = Some x} -> - prepare_warning_concat ~beg:false x ) +let supported_format (x : string) loc = + if x = Literals.commonjs then NodeJS + else if x = Literals.es6 then Es6 + else if x = Literals.es6_global then Es6_global + else bad_module_format_message_exn ~loc x - -let from_map (m : Ext_json_types.t Map_string.t) = - let number_opt = Map_string.find_opt m Bsb_build_schemas.number in - let error_opt = Map_string.find_opt m Bsb_build_schemas.error in - match number_opt, error_opt with - | None, None -> None - | _, _ -> - let error = - match error_opt with - | Some (True _) -> Warn_error_true - | Some (False _) -> Warn_error_false - | Some (Str {str ; }) - -> Warn_error_number str - | Some x -> Bsb_exception.config_error x "expect true/false or string" - | None -> Warn_error_false - (** To make it less intrusive : warning error has to be enabled*) - in - let number = - match number_opt with - | Some (Str { str = number}) -> Some number - | None -> None - | Some x -> Bsb_exception.config_error x "expect a string" - in - Some {number; error } -let to_bsb_string ~toplevel warning = - match warning with - | None -> Ext_string.empty - | Some warning -> - (match warning.number with - | None -> - Ext_string.empty - | Some x -> - prepare_warning_concat ~beg:true x - ) ^ - if toplevel then - match warning.error with - | Warn_error_true -> - " -warn-error A" - | Warn_error_number y -> - " -warn-error " ^ y - | Warn_error_false -> - Ext_string.empty - else Ext_string.empty +let string_of_format (x : format) = + match x with + | NodeJS -> Literals.commonjs + | Es6 -> Literals.es6 + | Es6_global -> Literals.es6_global -end -module Bs_hash_stubs -= struct -#1 "bs_hash_stubs.ml" +let prefix_of_format (x : format) = + match x with + | NodeJS -> Bsb_config.lib_js + | Es6 -> Bsb_config.lib_es6 + | Es6_global -> Bsb_config.lib_es6_global -external hash_string : string -> int = "caml_bs_hash_string" [@@noalloc];; +let bad_suffix_message_warn suffix = + Bsb_log.warn + "@{UNSUPPORTED@}: package-specs: extension `%s` is unsupported@;\ + ; consider one of: %s, %s, %s, or %s@." suffix Literals.suffix_js + Literals.suffix_mjs Literals.suffix_bs_js Literals.suffix_bs_mjs -external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" [@@noalloc];; -external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" [@@noalloc];; +let supported_suffix (x : string) = + if not (List.mem x Literals.[ suffix_js; suffix_bs_js; suffix_bs_mjs ]) then + bad_suffix_message_warn x; + x -external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" [@@noalloc];; -external hash_small_int : int -> int = "caml_bs_hash_small_int" [@@noalloc];; +let default_suffix format in_source = + (* In the absence of direction to the contrary, the suffix depends on + * [format] and [in_source]. *) + match (format, in_source) with + | NodeJS, false -> Literals.suffix_js + | NodeJS, true -> Literals.suffix_bs_js + | _, false -> Literals.suffix_mjs + | _, true -> Literals.suffix_bs_mjs -external hash_int : int -> int = "caml_bs_hash_int" [@@noalloc];; -external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];; +module SS = Set.Make (String) -external - int_unsafe_blit : - int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" [@@noalloc];; +let supported_bs_suffixes = Literals.[ suffix_bs_js; suffix_bs_mjs ] - +(** Produces a [list] of supported, bs-prefixed file-suffixes used in + [in-source] package-specs. *) +let extract_in_source_bs_suffixes (package_specs : Spec_set.t) = + let f spec suffixes = + if spec.in_source && List.mem spec.suffix supported_bs_suffixes then + SS.add spec.suffix suffixes + else suffixes + in + let suffixes = Spec_set.fold f package_specs SS.empty in + SS.elements suffixes -end -module Ext_util : sig -#1 "ext_util.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let rec from_array (arr : Ext_json_types.t array) : Spec_set.t = + let spec = ref Spec_set.empty in + let has_in_source = ref false in + Ext_array.iter arr (fun x -> + let result = from_json_single x in + if result.in_source then + if not !has_in_source then has_in_source := true + else + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "package-specs: we've detected two module formats that are both \ + configured to be in-source."; + spec := Spec_set.add result !spec); + !spec + + +(* TODO: FIXME: better API without mutating *) +and from_json_single (x : Ext_json_types.t) : spec = + match x with + | Str { str = format; loc } -> + let format = supported_format format loc in + { format; in_source = false; suffix = default_suffix format false } + | Obj { map; loc } -> ( + match Map_string.find_exn map Bsb_build_schemas._module with + | Str { str = format } -> + let format = supported_format format loc in + let in_source = + match Map_string.find_opt map Bsb_build_schemas.in_source with + | Some (True _) -> true + | Some _ | None -> false + in + let suffix = + match Map_string.find_opt map Bsb_build_schemas.suffix with + | Some (Str { str = suffix; loc }) -> supported_suffix suffix + | Some _ -> + Bsb_exception.errorf ~loc + "package-specs: the `suffix` field of the configuration \ + object must be absent, or a string." + | None -> default_suffix format in_source + in + { format; in_source; suffix } + | Arr _ -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, `module` \ + field should be a string, not an array. If you want to pass \ + multiple module specs, try turning package-specs into an array of \ + objects (or strings) instead." + | _ -> + Bsb_exception.errorf ~loc + "package-specs: the `module` field of the configuration object \ + should be a string." + | exception _ -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, the `module` \ + field is mandatory." ) + | _ -> + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "package-specs: we expect either a string or an object." + + +let from_json (x : Ext_json_types.t) : Spec_set.t = + match x with + | Arr { content; _ } -> from_array content + | _ -> Spec_set.singleton (from_json_single x) + + +let bs_package_output = "-bs-package-output" + +(** Assume input is valid + + {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) +let package_flag ({ format; in_source } : spec) dir = + Ext_string.inter2 bs_package_output + (Ext_string.concat3 (string_of_format format) Ext_string.single_colon + (if in_source then dir else prefix_of_format format // dir)) - -val power_2_above : int -> int -> int +let package_flag_of_package_specs (package_specs : t) (dirname : string) : + string = + Spec_set.fold + (fun format acc -> Ext_string.inter2 acc (package_flag format dirname)) + package_specs Ext_string.empty -val stats_to_string : Hashtbl.statistics -> string -end = struct -#1 "ext_util.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +let default_package_specs = + Spec_set.singleton + { format = NodeJS; in_source = false; suffix = default_suffix NodeJS false } -(** - {[ - (power_2_above 16 63 = 64) - (power_2_above 16 76 = 128) - ]} -*) -let rec power_2_above x n = - if x >= n then x - else if x * 2 > Sys.max_array_length then x - else power_2_above (x * 2) n + +(** [get_list_of_output_js specs true "src/hi/hello"] *) +let get_list_of_output_js (package_specs : Spec_set.t) + (output_file_sans_extension : string) = + Spec_set.fold + (fun spec acc -> + let basename = + Ext_namespace.replace_namespace_with_extension + ~name:output_file_sans_extension ~ext:spec.suffix + in + ( Bsb_config.proj_rel + @@ + if spec.in_source then basename + else prefix_of_format spec.format // basename ) + :: acc) + package_specs [] -let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = - Printf.sprintf - "bindings: %d,buckets: %d, longest: %d, hist:[%s]" - num_bindings - num_buckets - max_bucket_length - (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +let list_dirs_by (package_specs : Spec_set.t) (f : string -> unit) = + Spec_set.iter + (fun (spec : spec) -> + if not spec.in_source then f (prefix_of_format spec.format)) + package_specs + end -module Hash_set_gen +module Bsc_warnings = struct -#1 "hash_set_gen.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +#1 "bsc_warnings.ml" +(* Copyright (C) 2020- Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7182,174 +7248,39 @@ module Hash_set_gen * This program 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 Lesser General Public License for more details. - * + + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. *) - -type 'a bucket = - | Empty - | Cons of { - mutable key : 'a ; - mutable next : 'a bucket - } - -type 'a t = - { mutable size: int; (* number of entries *) - mutable data: 'a bucket array; (* the buckets *) - initial_size: int; (* initial array size *) - } - - - - -let create initial_size = - let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } - -let clear h = - h.size <- 0; - let len = Array.length h.data in - for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty - done - -let reset h = - h.size <- 0; - h.data <- Array.make h.initial_size Empty - -let length h = h.size - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin - let ndata = Array.make nsize Empty in - let ndata_tail = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - Empty -> () - | Cons {key; next} as cell -> - let nidx = indexfun h key in - begin match Array.unsafe_get ndata_tail nidx with - | Empty -> - Array.unsafe_set ndata nidx cell - | Cons tail -> - tail.next <- cell - end; - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done; - for i = 0 to nsize - 1 do - match Array.unsafe_get ndata_tail i with - | Empty -> () - | Cons tail -> tail.next <- Empty - done - end - -let iter h f = - let rec do_bucket = function - | Empty -> - () - | Cons l -> - f l.key ; do_bucket l.next in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) - done - -let fold h init f = - let rec do_bucket b accu = - match b with - Empty -> - accu - | Cons l -> - do_bucket l.next (f l.key accu) in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu - done; - !accu - - -let elements set = - fold set [] List.cons - - - - -let rec small_bucket_mem eq key lst = - match lst with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - small_bucket_mem eq key lst.next - -let rec remove_bucket - (h : _ t) (i : int) - key - ~(prec : _ bucket) - (buck : _ bucket) - eq_key = - match buck with - | Empty -> - () - | Cons {key=k; next } -> - if eq_key k key - then begin - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next - end - else remove_bucket h i key ~prec:buck next eq_key - - -module type S = -sig - type key - type t - val create: int -> t - val clear : t -> unit - val reset : t -> unit - (* val copy: t -> t *) - val remove: t -> key -> unit - val add : t -> key -> unit - val of_array : key array -> t - val check_add : t -> key -> bool - val mem : t -> key -> bool - val iter: t -> (key -> unit) -> unit - val fold: t -> 'b -> (key -> 'b -> 'b) -> 'b - val length: t -> int - (* val stats: t -> Hashtbl.statistics *) - val elements : t -> key list -end +(** + See the meanings of the warning codes here: https://caml.inria.fr/pub/docs/manual-ocaml/comp.html#sec281 + - 30 Two labels or constructors of the same name are defined in two mutually recursive types. + - 40 Constructor or label name used out of scope. -end -module Hash_set_string : sig -#1 "hash_set_string.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + - 6 Label omitted in function application. + - 7 Method overridden. + - 9 Missing fields in a record pattern. (*Not always desired, in some cases need [@@@warning "+9"] *) + - 27 Innocuous unused variable: unused variable that is not bound with let nor as, and doesn’t start with an underscore (_) character. + - 29 Unescaped end-of-line in a string constant (non-portable code). + - 32 .. 39 Unused blabla + - 44 Open statement shadows an already defined identifier. + - 45 Open statement shadows an already defined label or constructor. + - 48 Implicit elimination of optional arguments. https://caml.inria.fr/mantis/view.php?id=6352 + - 101 (bsb-specific) unsafe polymorphic comparison. +*) +let defaults_w = "-30-40+6+7+27+32..39+44+45+101" +let defaults_warn_error = "-a+5+101";; + +end +module Bsb_warning : sig +#1 "bsb_warning.mli" +(* Copyright (C) 2017 Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7367,19 +7298,35 @@ module Hash_set_string : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Hash_set_gen.S with type key = string + +type t + +(** Extra work is need to make merlin happy *) +val to_merlin_string : t -> string + + + +val from_map : Ext_json_types.t Map_string.t -> t + +(** [to_bsb_string not_dev warning] +*) +val to_bsb_string : + toplevel:bool -> + t -> + string + +val use_default : t end = struct -#1 "hash_set_string.ml" -# 1 "ext/hash_set.cppo.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +#1 "bsb_warning.ml" +(* Copyright (C) 2017 Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7397,170 +7344,123 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -# 31 "ext/hash_set.cppo.ml" -type key = string -let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1) -let eq_key = Ext_string.equal -type t = key Hash_set_gen.t -# 64 "ext/hash_set.cppo.ml" -let create = Hash_set_gen.create -let clear = Hash_set_gen.clear -let reset = Hash_set_gen.reset -(* let copy = Hash_set_gen.copy *) -let iter = Hash_set_gen.iter -let fold = Hash_set_gen.fold -let length = Hash_set_gen.length -(* let stats = Hash_set_gen.stats *) -let elements = Hash_set_gen.elements - +type warning_error = + | Warn_error_false + (* default [false] to make our changes non-intrusive *) + | Warn_error_true + | Warn_error_number of string +type t0 = { + number : string option; + error : warning_error +} -let remove (h : _ Hash_set_gen.t ) key = - let i = key_index h key in - let h_data = h.data in - Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key +type nonrec t = t0 option +let use_default = None +let prepare_warning_concat ~(beg : bool) s = + let s = Ext_string.trim s in + if s = "" then s + else + match s.[0] with + | '0' .. '9' -> if beg then "-w +" ^ s else "+" ^ s + | 'a' .. 'z' -> + if beg then "-w " ^ s else "+" ^ s + | _ -> + if beg then "-w " ^ s else s -let add (h : _ Hash_set_gen.t) key = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h - end +let to_merlin_string x = + "-w " ^ Bsc_warnings.defaults_w + ^ + (match x with + | Some {number =None} + | None -> Ext_string.empty + | Some {number = Some x} -> + prepare_warning_concat ~beg:false x ) -let of_array arr = - let len = Array.length arr in - let tbl = create len in - for i = 0 to len - 1 do - add tbl (Array.unsafe_get arr i); - done ; - tbl - - -let check_add (h : _ Hash_set_gen.t) key : bool = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; - true - end - else false + +let from_map (m : Ext_json_types.t Map_string.t) = + let number_opt = Map_string.find_opt m Bsb_build_schemas.number in + let error_opt = Map_string.find_opt m Bsb_build_schemas.error in + match number_opt, error_opt with + | None, None -> None + | _, _ -> + let error = + match error_opt with + | Some (True _) -> Warn_error_true + | Some (False _) -> Warn_error_false + | Some (Str {str ; }) + -> Warn_error_number str + | Some x -> Bsb_exception.config_error x "expect true/false or string" + | None -> Warn_error_false + (** To make it less intrusive : warning error has to be enabled*) + in + let number = + match number_opt with + | Some (Str { str = number}) -> Some number + | None -> None + | Some x -> Bsb_exception.config_error x "expect a string" + in + Some {number; error } -let mem (h : _ Hash_set_gen.t) key = - Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) +let to_bsb_string ~toplevel warning = + match warning with + | None -> Ext_string.empty + | Some warning -> + (match warning.number with + | None -> + Ext_string.empty + | Some x -> + prepare_warning_concat ~beg:true x + ) ^ + if toplevel then + match warning.error with + | Warn_error_true -> + " -warn-error A" + | Warn_error_number y -> + " -warn-error " ^ y + | Warn_error_false -> + Ext_string.empty + else Ext_string.empty - end -module Bsb_config_types +module Bs_hash_stubs = struct -#1 "bsb_config_types.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +#1 "bs_hash_stubs.ml" -type dependency = - { - package_name : Bsb_pkg_types.t ; - package_install_path : string ; - } -type dependencies = dependency list +external hash_string : string -> int = "caml_bs_hash_string" [@@noalloc];; -(* `string` is a path to the entrypoint *) -type entries_t = JsTarget of string | NativeTarget of string | BytecodeTarget of string +external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" [@@noalloc];; -type compilation_kind_t = Js | Bytecode | Native +external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" [@@noalloc];; -type reason_react_jsx = - | Jsx_v2 - | Jsx_v3 - (* string option *) +external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" [@@noalloc];; -type refmt = string option +external hash_small_int : int -> int = "caml_bs_hash_small_int" [@@noalloc];; -type gentype_config = { - path : string (* resolved *) -} -type command = string +external hash_int : int -> int = "caml_bs_hash_int" [@@noalloc];; -type ppx = { - name : string; - args : string list -} -type t = - { - package_name : string ; - (* [captial-package] *) - namespace : string option; - (* CapitalPackage *) - external_includes : string list ; - bsc_flags : string list ; - ppx_files : ppx list ; - pp_file : string option; - bs_dependencies : dependencies; - bs_dev_dependencies : dependencies; - built_in_dependency : dependency option; - warning : Bsb_warning.t; - (*TODO: maybe we should always resolve bs-platform - so that we can calculate correct relative path in - [.merlin] - *) - refmt : refmt; - js_post_build_cmd : string option; - package_specs : Bsb_package_specs.t ; - file_groups : Bsb_file_groups.t; - files_to_install : Hash_set_string.t ; - generate_merlin : bool ; - reason_react_jsx : reason_react_jsx option; (* whether apply PPX transform or not*) - entries : entries_t list ; - generators : command Map_string.t ; - cut_generators : bool; (* note when used as a dev mode, we will always ignore it *) - bs_suffix : bool ; (* true means [.bs.js] we should pass [-bs-suffix] flag *) - gentype_config : gentype_config option; - number_of_dev_groups : int - } +external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];; + +external + int_unsafe_blit : + int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" [@@noalloc];; + + end -module Ext_color : sig -#1 "ext_color.mli" +module Ext_util : sig +#1 "ext_util.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -7585,29 +7485,14 @@ module Ext_color : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type color - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - -type style - = FG of color - | BG of color - | Bold - | Dim -(** Input is the tag for example `@{@}` return escape code *) -val ansi_of_tag : string -> string + +val power_2_above : int -> int -> int -val reset_lit : string +val stats_to_string : Hashtbl.statistics -> string end = struct -#1 "ext_color.ml" +#1 "ext_util.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -7632,86 +7517,214 @@ 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. *) +(** + {[ + (power_2_above 16 63 = 64) + (power_2_above 16 76 = 128) + ]} +*) +let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + +let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = + Printf.sprintf + "bindings: %d,buckets: %d, longest: %d, hist:[%s]" + num_bindings + num_buckets + max_bucket_length + (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +end +module Hash_set_gen += struct +#1 "hash_set_gen.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type color - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) -type style - = FG of color - | BG of color - | Bold - | Dim +type 'a bucket = + | Empty + | Cons of { + mutable key : 'a ; + mutable next : 'a bucket + } +type 'a t = + { mutable size: int; (* number of entries *) + mutable data: 'a bucket array; (* the buckets *) + initial_size: int; (* initial array size *) + } -let ansi_of_color = function - | Black -> "0" - | Red -> "1" - | Green -> "2" - | Yellow -> "3" - | Blue -> "4" - | Magenta -> "5" - | Cyan -> "6" - | White -> "7" -let code_of_style = function - | FG Black -> "30" - | FG Red -> "31" - | FG Green -> "32" - | FG Yellow -> "33" - | FG Blue -> "34" - | FG Magenta -> "35" - | FG Cyan -> "36" - | FG White -> "37" - - | BG Black -> "40" - | BG Red -> "41" - | BG Green -> "42" - | BG Yellow -> "43" - | BG Blue -> "44" - | BG Magenta -> "45" - | BG Cyan -> "46" - | BG White -> "47" - | Bold -> "1" - | Dim -> "2" +let create initial_size = + let s = Ext_util.power_2_above 16 initial_size in + { initial_size = s; size = 0; data = Array.make s Empty } +let clear h = + h.size <- 0; + let len = Array.length h.data in + for i = 0 to len - 1 do + Array.unsafe_set h.data i Empty + done -(** TODO: add more styles later *) -let style_of_tag s = match s with - | "error" -> [Bold; FG Red] - | "warning" -> [Bold; FG Magenta] - | "info" -> [Bold; FG Yellow] - | "dim" -> [Dim] - | "filename" -> [FG Cyan] - | _ -> [] +let reset h = + h.size <- 0; + h.data <- Array.make h.initial_size Empty -let ansi_of_tag s = - let l = style_of_tag s in - let s = String.concat ";" (Ext_list.map l code_of_style) in - "\x1b[" ^ s ^ "m" +let length h = h.size + +let resize indexfun h = + let odata = h.data in + let osize = Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then begin + let ndata = Array.make nsize Empty in + let ndata_tail = Array.make nsize Empty in + h.data <- ndata; (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + Empty -> () + | Cons {key; next} as cell -> + let nidx = indexfun h key in + begin match Array.unsafe_get ndata_tail nidx with + | Empty -> + Array.unsafe_set ndata nidx cell + | Cons tail -> + tail.next <- cell + end; + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next + in + for i = 0 to osize - 1 do + insert_bucket (Array.unsafe_get odata i) + done; + for i = 0 to nsize - 1 do + match Array.unsafe_get ndata_tail i with + | Empty -> () + | Cons tail -> tail.next <- Empty + done + end + +let iter h f = + let rec do_bucket = function + | Empty -> + () + | Cons l -> + f l.key ; do_bucket l.next in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket (Array.unsafe_get d i) + done + +let fold h init f = + let rec do_bucket b accu = + match b with + Empty -> + accu + | Cons l -> + do_bucket l.next (f l.key accu) in + let d = h.data in + let accu = ref init in + for i = 0 to Array.length d - 1 do + accu := do_bucket (Array.unsafe_get d i) !accu + done; + !accu +let elements set = + fold set [] List.cons -let reset_lit = "\x1b[0m" +let rec small_bucket_mem eq key lst = + match lst with + | Empty -> false + | Cons lst -> + eq key lst.key || + match lst.next with + | Empty -> false + | Cons lst -> + eq key lst.key || + match lst.next with + | Empty -> false + | Cons lst -> + eq key lst.key || + small_bucket_mem eq key lst.next + +let rec remove_bucket + (h : _ t) (i : int) + key + ~(prec : _ bucket) + (buck : _ bucket) + eq_key = + match buck with + | Empty -> + () + | Cons {key=k; next } -> + if eq_key k key + then begin + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next + end + else remove_bucket h i key ~prec:buck next eq_key + + +module type S = +sig + type key + type t + val create: int -> t + val clear : t -> unit + val reset : t -> unit + (* val copy: t -> t *) + val remove: t -> key -> unit + val add : t -> key -> unit + val of_array : key array -> t + val check_add : t -> key -> bool + val mem : t -> key -> bool + val iter: t -> (key -> unit) -> unit + val fold: t -> 'b -> (key -> 'b -> 'b) -> 'b + val length: t -> int + (* val stats: t -> Hashtbl.statistics *) + val elements : t -> key list +end + end -module Bsb_log : sig -#1 "bsb_log.mli" -(* Copyright (C) 2017 Authors of BuckleScript +module Hash_set_string : sig +#1 "hash_set_string.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -7736,31 +7749,12 @@ module Bsb_log : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val setup : unit -> unit - -type level = - | Debug - | Info - | Warn - | Error - -val log_level : level ref - -type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a - -type 'a log = ('a, Format.formatter, unit) format -> 'a - -val verbose : unit -> unit -val debug : 'a log -val info : 'a log -val warn : 'a log -val error : 'a log - -val info_args : string array -> unit +include Hash_set_gen.S with type key = string end = struct -#1 "bsb_log.ml" -(* Copyright (C) 2017- Authors of BuckleScript +#1 "hash_set_string.ml" +# 1 "ext/hash_set.cppo.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -7783,92 +7777,161 @@ end = struct * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +# 31 "ext/hash_set.cppo.ml" +type key = string +let key_index (h : _ Hash_set_gen.t ) (key : key) = + (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1) +let eq_key = Ext_string.equal +type t = key Hash_set_gen.t +# 64 "ext/hash_set.cppo.ml" +let create = Hash_set_gen.create +let clear = Hash_set_gen.clear +let reset = Hash_set_gen.reset +(* let copy = Hash_set_gen.copy *) +let iter = Hash_set_gen.iter +let fold = Hash_set_gen.fold +let length = Hash_set_gen.length +(* let stats = Hash_set_gen.stats *) +let elements = Hash_set_gen.elements -let ninja_ansi_forced = lazy - (try Sys.getenv "NINJA_ANSI_FORCED" with - Not_found ->"" - ) -let color_enabled = lazy (Unix.isatty Unix.stdout) -(* same logic as [ninja.exe] *) -let get_color_enabled () = - let colorful = - match ninja_ansi_forced with - | lazy "1" -> true - | lazy ("0" | "false") -> false - | _ -> - Lazy.force color_enabled in - colorful +let remove (h : _ Hash_set_gen.t ) key = + let i = key_index h key in + let h_data = h.data in + Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key -let color_functions : Format.formatter_tag_functions = { - mark_open_tag = (fun s -> if get_color_enabled () then Ext_color.ansi_of_tag s else Ext_string.empty) ; - mark_close_tag = (fun _ -> if get_color_enabled () then Ext_color.reset_lit else Ext_string.empty); - print_open_tag = (fun _ -> ()); - print_close_tag = (fun _ -> ()) -} -let set_color ppf = - Format.pp_set_formatter_tag_functions ppf color_functions +let add (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + let old_bucket = (Array.unsafe_get h_data i) in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then + begin + Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); + h.size <- h.size + 1 ; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h + end +let of_array arr = + let len = Array.length arr in + let tbl = create len in + for i = 0 to len - 1 do + add tbl (Array.unsafe_get arr i); + done ; + tbl + + +let check_add (h : _ Hash_set_gen.t) key : bool = + let i = key_index h key in + let h_data = h.data in + let old_bucket = (Array.unsafe_get h_data i) in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then + begin + Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); + h.size <- h.size + 1 ; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; + true + end + else false -let setup () = - begin - Format.pp_set_mark_tags Format.std_formatter true ; - Format.pp_set_mark_tags Format.err_formatter true; - Format.pp_set_formatter_tag_functions - Format.std_formatter color_functions; - Format.pp_set_formatter_tag_functions - Format.err_formatter color_functions - end -type level = - | Debug - | Info - | Warn - | Error +let mem (h : _ Hash_set_gen.t) key = + Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) -let int_of_level (x : level) = - match x with - | Debug -> 0 - | Info -> 1 - | Warn -> 2 - | Error -> 3 + -let log_level = ref Warn +end +module Bsb_config_types += struct +#1 "bsb_config_types.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let verbose () = - log_level := Debug -let dfprintf level fmt = - if int_of_level level >= int_of_level !log_level then - Format.fprintf fmt - else Format.ifprintf fmt -type 'a fmt = - Format.formatter -> ('a, Format.formatter, unit) format -> 'a -type 'a log = - ('a, Format.formatter, unit) format -> 'a +type dependency = + { + package_name : Bsb_pkg_types.t ; + package_install_path : string ; + } +type dependencies = dependency list -let debug fmt = dfprintf Debug Format.std_formatter fmt -let info fmt = dfprintf Info Format.std_formatter fmt -let warn fmt = dfprintf Warn Format.err_formatter fmt -let error fmt = dfprintf Error Format.err_formatter fmt +(* `string` is a path to the entrypoint *) +type entries_t = JsTarget of string | NativeTarget of string | BytecodeTarget of string +type compilation_kind_t = Js | Bytecode | Native -let info_args (args : string array) = - if int_of_level Info >= int_of_level !log_level then - begin - for i = 0 to Array.length args - 1 do - Format.pp_print_string Format.std_formatter (Array.unsafe_get args i) ; - Format.pp_print_string Format.std_formatter Ext_string.single_space; - done ; - Format.pp_print_newline Format.std_formatter () - end - else () - +type reason_react_jsx = + | Jsx_v2 + | Jsx_v3 + (* string option *) + +type refmt = string option + +type gentype_config = { + path : string (* resolved *) +} +type command = string + +type ppx = { + name : string; + args : string list +} +type t = + { + package_name : string ; + (* [captial-package] *) + namespace : string option; + (* CapitalPackage *) + external_includes : string list ; + bsc_flags : string list ; + ppx_files : ppx list ; + pp_file : string option; + bs_dependencies : dependencies; + bs_dev_dependencies : dependencies; + built_in_dependency : dependency option; + warning : Bsb_warning.t; + (*TODO: maybe we should always resolve bs-platform + so that we can calculate correct relative path in + [.merlin] + *) + refmt : refmt; + js_post_build_cmd : string option; + package_specs : Bsb_package_specs.t ; + file_groups : Bsb_file_groups.t; + files_to_install : Hash_set_string.t ; + generate_merlin : bool ; + reason_react_jsx : reason_react_jsx option; (* whether apply PPX transform or not*) + entries : entries_t list ; + generators : command Map_string.t ; + cut_generators : bool; (* note when used as a dev mode, we will always ignore it *) + gentype_config : gentype_config option; + number_of_dev_groups : int + } end module Bsb_real_path : sig @@ -10233,7 +10296,7 @@ val scan : root:string -> cut_generators:bool -> namespace:string option -> - bs_suffix:bool -> + bs_suffixes:string list -> ignored_dirs:Set_string.t -> Ext_json_types.t -> Bsb_file_groups.t * int @@ -10292,7 +10355,7 @@ type cxt = { cut_generators : bool; traverse : bool; namespace : string option; - bs_suffix : bool; + bs_suffixes : string list; ignored_dirs : Set_string.t; } @@ -10452,6 +10515,13 @@ let classify_suffix (x : string) : suffix_kind = if i >= 0 then Cmti i else Not_any +(** Attempt to delete any [.bs.m?js] files for a given artifact. *) +let unlink_bs_suffixes context artifact = + List.iter + (fun suffix -> try_unlink (Filename.concat context.cwd (artifact ^ suffix))) + context.bs_suffixes + + (* This is the only place where we do some removal during scanning, configurably. *) let prune_staled_bs_js_files (context : cxt) (cur_sources : _ Map_string.t) : @@ -10482,12 +10552,7 @@ let prune_staled_bs_js_files (context : cxt) (cur_sources : _ Map_string.t) : if cmd <> "" then Ext_pervasives.try_it (fun _ -> Sys.command (cmd ^ " -cmt-rm " ^ filepath)) - | Cmj _ -> - (* remove .bs.js *) - if context.bs_suffix then - try_unlink - (Filename.concat context.cwd - (String.sub x 0 j ^ Literals.suffix_bs_js)) + | Cmj _ -> unlink_bs_suffixes context (String.sub x 0 j) | _ -> () ); try_unlink filepath ) else () @@ -10647,8 +10712,8 @@ and parse_sources (cxt : cxt) (sources : Ext_json_types.t) = | _ -> parsing_single_source cxt sources -let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffix ~ignored_dirs x : - t * int = +let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffixes ~ignored_dirs x + : t * int = Bsb_dir_index.reset (); let output = parse_sources @@ -10660,7 +10725,7 @@ let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffix ~ignored_dirs x : root; cut_generators; namespace; - bs_suffix; + bs_suffixes; traverse = false; } x @@ -11159,17 +11224,6 @@ let check_stdlib (map : json_map) cwd (*built_in_package*) = | _ -> assert false ) -let extract_bs_suffix_exn (map : json_map) = - match Map_string.find_opt map Bsb_build_schemas.suffix with - | None -> false - | Some (Str { str } as config) -> - if str = Literals.suffix_js then false - else if str = Literals.suffix_bs_js then true - else Bsb_exception.config_error config "expect .bs.js or .js string here" - | Some config -> - Bsb_exception.config_error config "expect .bs.js or .js string here" - - let extract_gentype_config (map : json_map) cwd : Bsb_config_types.gentype_config option = match Map_string.find_opt map Bsb_build_schemas.gentypeconfig with @@ -11375,7 +11429,6 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : let package_name, namespace = extract_package_name_and_namespace map in let refmt = extract_refmt map per_proj_dir in let gentype_config = extract_gentype_config map per_proj_dir in - let bs_suffix = extract_bs_suffix_exn map in (* The default situation is empty *) let built_in_package = check_stdlib map per_proj_dir in let package_specs = @@ -11383,6 +11436,9 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : | Some x -> Bsb_package_specs.from_json x | None -> Bsb_package_specs.default_package_specs in + let bs_suffixes = + Bsb_package_specs.extract_in_source_bs_suffixes package_specs + in let pp_flags : string option = extract_string map Bsb_build_schemas.pp_flags (fun p -> if p = "" then @@ -11411,12 +11467,11 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : in let groups, number_of_dev_groups = Bsb_parse_sources.scan ~ignored_dirs:(extract_ignored_dirs map) - ~toplevel ~root:per_proj_dir ~cut_generators ~bs_suffix ~namespace - sources + ~toplevel ~root:per_proj_dir ~cut_generators ~bs_suffixes + ~namespace sources in { gentype_config; - bs_suffix; package_name; namespace; warning = extract_warning map; @@ -12403,7 +12458,6 @@ val make_custom_rules : has_ppx:bool -> has_pp:bool -> has_builtin:bool -> - bs_suffix:bool -> reason_react_jsx:Bsb_config_types.reason_react_jsx option -> digest:string -> refmt:string option -> @@ -12513,7 +12567,7 @@ type builtin = { } let make_custom_rules ~(has_gentype : bool) ~(has_postbuild : bool) - ~(has_ppx : bool) ~(has_pp : bool) ~(has_builtin : bool) ~(bs_suffix : bool) + ~(has_ppx : bool) ~(has_pp : bool) ~(has_builtin : bool) ~(reason_react_jsx : Bsb_config_types.reason_react_jsx option) ~(digest : string) ~(refmt : string option) (* set refmt path when needed *) @@ -12524,7 +12578,6 @@ let make_custom_rules ~(has_gentype : bool) ~(has_postbuild : bool) let mk_ml_cmj_cmd ~read_cmi ~is_dev ~postbuild : string = Buffer.clear buf; Buffer.add_string buf "$bsc -nostdlib $g_pkg_flg -color always"; - if bs_suffix then Buffer.add_string buf " -bs-suffix"; if read_cmi then Buffer.add_string buf " -bs-read-cmi"; if is_dev then Buffer.add_string buf " $g_dev_incls"; Buffer.add_string buf " $g_lib_incls"; @@ -12871,7 +12924,6 @@ module Bsb_ninja_file_groups : sig val handle_files_per_dir : out_channel -> - bs_suffix:bool -> rules:Bsb_ninja_rule.builtin -> package_specs:Bsb_package_specs.t -> js_post_build_cmd:string option -> @@ -12944,7 +12996,7 @@ let make_common_shadows package_specs dirname dir_index : let emit_module_build (rules : Bsb_ninja_rule.builtin) (package_specs : Bsb_package_specs.t) (group_dir_index : Bsb_dir_index.t) oc - ~bs_suffix js_post_build_cmd namespace (module_info : Bsb_db.module_info) = + js_post_build_cmd namespace (module_info : Bsb_db.module_info) = let has_intf_file = module_info.info = Ml_mli in let is_re = module_info.is_re in let filename_sans_extension = module_info.name_sans_extension in @@ -12974,7 +13026,7 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) let output_cmi = output_filename_sans_extension ^ Literals.suffix_cmi in let output_cmj = output_filename_sans_extension ^ Literals.suffix_cmj in let output_js = - Bsb_package_specs.get_list_of_output_js package_specs bs_suffix + Bsb_package_specs.get_list_of_output_js package_specs output_filename_sans_extension in let common_shadows = @@ -13039,8 +13091,8 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) ~order_only_deps:[ output_d ] ~rule -let handle_files_per_dir oc ~bs_suffix ~(rules : Bsb_ninja_rule.builtin) - ~package_specs ~js_post_build_cmd ~(files_to_install : Hash_set_string.t) +let handle_files_per_dir oc ~(rules : Bsb_ninja_rule.builtin) ~package_specs + ~js_post_build_cmd ~(files_to_install : Hash_set_string.t) ~(namespace : string option) (group : Bsb_file_groups.file_group) : unit = handle_generators oc group rules.customs; let installable = @@ -13052,8 +13104,8 @@ let handle_files_per_dir oc ~bs_suffix ~(rules : Bsb_ninja_rule.builtin) Map_string.iter group.sources (fun module_name module_info -> if installable module_name then Hash_set_string.add files_to_install module_info.name_sans_extension; - emit_module_build rules package_specs group.dir_index oc ~bs_suffix - js_post_build_cmd namespace module_info) + emit_module_build rules package_specs group.dir_index oc js_post_build_cmd + namespace module_info) (* pseuduo targets per directory *) @@ -13162,7 +13214,6 @@ let output_static_resources (static_resources : string list) copy_rule oc = let output_ninja_and_namespace_map ~per_proj_dir ~toplevel ({ - bs_suffix; package_name; external_includes; bsc_flags; @@ -13287,7 +13338,7 @@ let output_ninja_and_namespace_map ~per_proj_dir ~toplevel ~has_postbuild:(js_post_build_cmd <> None) ~has_ppx:(ppx_files <> []) ~has_pp:(pp_file <> None) ~has_builtin:(built_in_dependency <> None) - ~reason_react_jsx ~bs_suffix ~digest generators + ~reason_react_jsx ~digest generators in emit_bsc_lib_includes bs_dependencies bsc_lib_dirs external_includes namespace @@ -13295,9 +13346,8 @@ let output_ninja_and_namespace_map ~per_proj_dir ~toplevel output_static_resources static_resources rules.copy_resources oc; (* Generate build statement for each file *) Ext_list.iter bs_file_groups (fun files_per_dir -> - Bsb_ninja_file_groups.handle_files_per_dir oc ~bs_suffix ~rules - ~js_post_build_cmd ~package_specs ~files_to_install ~namespace - files_per_dir); + Bsb_ninja_file_groups.handle_files_per_dir oc ~rules ~js_post_build_cmd + ~package_specs ~files_to_install ~namespace files_per_dir); Ext_option.iter namespace (fun ns -> let namespace_dir = per_proj_dir // Bsb_config.lib_bs in diff --git a/lib/4.06.1/bsb_helper.ml b/lib/4.06.1/bsb_helper.ml index 9fd114d11f..da9cac7207 100644 --- a/lib/4.06.1/bsb_helper.ml +++ b/lib/4.06.1/bsb_helper.ml @@ -2977,7 +2977,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -3116,7 +3118,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -3681,7 +3685,10 @@ val make : ?ns:string -> string -> string val try_split_module_name : string -> (string * string) option -val change_ext_ns_suffix : string -> string -> string +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) type file_kind = Upper_js | Upper_bs | Little_js | Little_bs @@ -3751,7 +3758,7 @@ let rec rindex_rec s i = #1933 when removing ns suffix, don't pass the bound of basename FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = +let replace_namespace_with_extension ~name ~ext = let i = rindex_rec name (String.length name - 1) in if i < 0 then name ^ ext else String.sub name 0 i ^ ext @@ -3768,13 +3775,16 @@ type file_kind = Upper_js | Upper_bs | Little_js | Little_bs let js_name_of_modulename s little = match little with | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js (** https://docs.npmjs.com/files/package.json diff --git a/lib/4.06.1/bsdep.ml b/lib/4.06.1/bsdep.ml index 9de00e5eea..2c0246178f 100644 --- a/lib/4.06.1/bsdep.ml +++ b/lib/4.06.1/bsdep.ml @@ -36328,7 +36328,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -36346,29 +36346,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit - -val warn_literal_overflow : Location.t -> unit +val warn_literal_overflow : Location.t -> unit -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -36386,117 +36382,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end + Format.pp_print_flush warning_formatter () ) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error + Provide a printer to error -(** - Note the standard way of reporting error in compiler: - - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type - - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Ext_util : sig @@ -37200,7 +37177,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -37339,7 +37318,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" diff --git a/lib/4.06.1/bsppx.ml b/lib/4.06.1/bsppx.ml index aa562ddac1..f0708a24ef 100644 --- a/lib/4.06.1/bsppx.ml +++ b/lib/4.06.1/bsppx.ml @@ -293504,7 +293504,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -293522,29 +293522,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit - -val warn_literal_overflow : Location.t -> unit +val warn_literal_overflow : Location.t -> unit -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -293562,117 +293558,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end - + Format.pp_print_flush warning_formatter () ) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error -(** - Note the standard way of reporting error in compiler: - - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type + Provide a printer to error - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Ext_util : sig @@ -294376,7 +294353,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -294515,7 +294494,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml index 46b8e3a53f..3a4b1d1d7b 100644 --- a/lib/4.06.1/unstable/all_ounit_tests.ml +++ b/lib/4.06.1/unstable/all_ounit_tests.ml @@ -5106,7 +5106,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -5245,7 +5247,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -16312,7 +16316,10 @@ val make : ?ns:string -> string -> string val try_split_module_name : string -> (string * string) option -val change_ext_ns_suffix : string -> string -> string +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) type file_kind = Upper_js | Upper_bs | Little_js | Little_bs @@ -16382,7 +16389,7 @@ let rec rindex_rec s i = #1933 when removing ns suffix, don't pass the bound of basename FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = +let replace_namespace_with_extension ~name ~ext = let i = rindex_rec name (String.length name - 1) in if i < 0 then name ^ ext else String.sub name 0 i ^ ext @@ -16399,13 +16406,16 @@ type file_kind = Upper_js | Upper_bs | Little_js | Little_bs let js_name_of_modulename s little = match little with | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js (** https://docs.npmjs.com/files/package.json @@ -16857,10 +16867,16 @@ let suites = =~"ABb" end; __LOC__ >:: begin fun _ -> - Ext_namespace.change_ext_ns_suffix "a-b" Literals.suffix_js =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a-" Literals.suffix_js =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a--" Literals.suffix_js =~ "a-.js"; - Ext_namespace.change_ext_ns_suffix "AA-b" Literals.suffix_js =~ "AA.js"; + Ext_namespace.replace_namespace_with_extension + ~name:"a-b" ~ext:Literals.suffix_js =~ "a.js"; + Ext_namespace.replace_namespace_with_extension + ~name:"a-" ~ext:Literals.suffix_js =~ "a.js"; + Ext_namespace.replace_namespace_with_extension + ~name:"a--" ~ext:Literals.suffix_js =~ "a-.js"; + Ext_namespace.replace_namespace_with_extension + ~name:"AA-b" ~ext:Literals.suffix_js =~ "AA.js"; + Ext_namespace.replace_namespace_with_extension + ~name:"AA-b" ~ext:Literals.suffix_js =~ "AA.js"; Ext_namespace.js_name_of_modulename "AA-b" Little_js =~ "aA.js"; Ext_namespace.js_name_of_modulename "AA-b" Upper_js =~ "AA.js"; Ext_namespace.js_name_of_modulename "AA-b" Upper_bs =~ "AA.bs.js" diff --git a/lib/4.06.1/unstable/bsb_native.ml b/lib/4.06.1/unstable/bsb_native.ml index d0e7f457ad..a2176c54c2 100644 --- a/lib/4.06.1/unstable/bsb_native.ml +++ b/lib/4.06.1/unstable/bsb_native.ml @@ -141,11 +141,12 @@ let generators = "generators" let command = "command" let edge = "edge" let namespace = "namespace" +let _module = "module" let in_source = "in-source" +let suffix = "suffix" let warnings = "warnings" let number = "number" let error = "error" -let suffix = "suffix" let gentypeconfig = "gentypeconfig" let path = "path" let ignored_dirs = "ignored-dirs" @@ -4465,7 +4466,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -4604,7 +4607,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -5861,344 +5866,159 @@ let () = ) end -module Ext_buffer : sig -#1 "ext_buffer.mli" -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(** Extensible buffers. - - This module implements buffers that automatically expand - as necessary. It provides accumulative concatenation of strings - in quasi-linear time (instead of quadratic time when strings are - concatenated pairwise). -*) - -(* BuckleScript customization: customized for efficient digest *) - -type t -(** The abstract type of buffers. *) - -val create : int -> t -(** [create n] returns a fresh buffer, initially empty. - The [n] parameter is the initial size of the internal byte sequence - that holds the buffer contents. That byte sequence is automatically - reallocated when more than [n] characters are stored in the buffer, - but shrinks back to [n] characters when [reset] is called. - For best performance, [n] should be of the same order of magnitude - as the number of characters that are expected to be stored in - the buffer (for instance, 80 for a buffer that holds one output - line). Nothing bad will happen if the buffer grows beyond that - limit, however. In doubt, take [n = 16] for instance. - If [n] is not between 1 and {!Sys.max_string_length}, it will - be clipped to that interval. *) +module Ext_color : sig +#1 "ext_color.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val contents : t -> string -(** Return a copy of the current contents of the buffer. - The buffer itself is unchanged. *) +type color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White -val length : t -> int -(** Return the number of characters currently contained in the buffer. *) +type style + = FG of color + | BG of color + | Bold + | Dim -val is_empty : t -> bool +(** Input is the tag for example `@{@}` return escape code *) +val ansi_of_tag : string -> string -val clear : t -> unit -(** Empty the buffer. *) +val reset_lit : string +end = struct +#1 "ext_color.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val add_char : t -> char -> unit -(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) -val add_string : t -> string -> unit -(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) -val add_bytes : t -> bytes -> unit -(** [add_string b s] appends the string [s] at the end of the buffer [b]. - @since 4.02 *) -val add_substring : t -> string -> int -> int -> unit -(** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in string [s] and appends them at the end of the buffer [b]. *) +type color + = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White -val add_subbytes : t -> bytes -> int -> int -> unit -(** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. - @since 4.02 *) +type style + = FG of color + | BG of color + | Bold + | Dim -val add_buffer : t -> t -> unit -(** [add_buffer b1 b2] appends the current contents of buffer [b2] - at the end of buffer [b1]. [b2] is not modified. *) -val add_channel : t -> in_channel -> int -> unit -(** [add_channel b ic n] reads exactly [n] character from the - input channel [ic] and stores them at the end of buffer [b]. - Raise [End_of_file] if the channel contains fewer than [n] - characters. *) +let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" -val output_buffer : out_channel -> t -> unit -(** [output_buffer oc b] writes the current contents of buffer [b] - on the output channel [oc]. *) +let code_of_style = function + | FG Black -> "30" + | FG Red -> "31" + | FG Green -> "32" + | FG Yellow -> "33" + | FG Blue -> "34" + | FG Magenta -> "35" + | FG Cyan -> "36" + | FG White -> "37" + + | BG Black -> "40" + | BG Red -> "41" + | BG Green -> "42" + | BG Yellow -> "43" + | BG Blue -> "44" + | BG Magenta -> "45" + | BG Cyan -> "46" + | BG White -> "47" -val digest : t -> Digest.t + | Bold -> "1" + | Dim -> "2" -val not_equal : - t -> - string -> - bool -val add_int_1 : - t -> int -> unit -val add_int_2 : - t -> int -> unit +(** TODO: add more styles later *) +let style_of_tag s = match s with + | "error" -> [Bold; FG Red] + | "warning" -> [Bold; FG Magenta] + | "info" -> [Bold; FG Yellow] + | "dim" -> [Dim] + | "filename" -> [FG Cyan] + | _ -> [] -val add_int_3 : - t -> int -> unit +let ansi_of_tag s = + let l = style_of_tag s in + let s = String.concat ";" (Ext_list.map l code_of_style) in + "\x1b[" ^ s ^ "m" -val add_int_4 : - t -> int -> unit -val add_string_char : - t -> - string -> - char -> - unit -val add_char_string : - t -> - char -> - string -> - unit -end = struct -#1 "ext_buffer.ml" -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) +let reset_lit = "\x1b[0m" -(* Extensible buffers *) - -type t = - {mutable buffer : bytes; - mutable position : int; - mutable length : int; - initial_buffer : bytes} - -let create n = - let n = if n < 1 then 1 else n in - - let n = if n > Sys.max_string_length then Sys.max_string_length else n in - - let s = Bytes.create n in - {buffer = s; position = 0; length = n; initial_buffer = s} - -let contents b = Bytes.sub_string b.buffer 0 b.position -let to_bytes b = Bytes.sub b.buffer 0 b.position - -let sub b ofs len = - if ofs < 0 || len < 0 || ofs > b.position - len - then invalid_arg "Ext_buffer.sub" - else Bytes.sub_string b.buffer ofs len - - -let blit src srcoff dst dstoff len = - if len < 0 || srcoff < 0 || srcoff > src.position - len - || dstoff < 0 || dstoff > (Bytes.length dst) - len - then invalid_arg "Ext_buffer.blit" - else - Bytes.unsafe_blit src.buffer srcoff dst dstoff len - -let length b = b.position -let is_empty b = b.position = 0 -let clear b = b.position <- 0 - -let reset b = - b.position <- 0; b.buffer <- b.initial_buffer; - b.length <- Bytes.length b.buffer - -let resize b more = - let len = b.length in - let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - else failwith "Ext_buffer.add: cannot grow buffer" - end; - - let new_buffer = Bytes.create !new_len in - (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. *) - Bytes.blit b.buffer 0 new_buffer 0 b.position; - b.buffer <- new_buffer; - b.length <- !new_len ; - assert (b.position + more <= b.length) - -let add_char b c = - let pos = b.position in - if pos >= b.length then resize b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - -let add_substring b s offset len = - if offset < 0 || len < 0 || offset > String.length s - len - then invalid_arg "Ext_buffer.add_substring/add_subbytes"; - let new_position = b.position + len in - if new_position > b.length then resize b len; - Ext_bytes.unsafe_blit_string s offset b.buffer b.position len; - b.position <- new_position - - -let add_subbytes b s offset len = - add_substring b (Bytes.unsafe_to_string s) offset len - -let add_string b s = - let len = String.length s in - let new_position = b.position + len in - if new_position > b.length then resize b len; - Ext_bytes.unsafe_blit_string s 0 b.buffer b.position len; - b.position <- new_position - -(* TODO: micro-optimzie *) -let add_string_char b s c = - let s_len = String.length s in - let len = s_len + 1 in - let new_position = b.position + len in - if new_position > b.length then resize b len; - let b_buffer = b.buffer in - Ext_bytes.unsafe_blit_string s 0 b_buffer b.position s_len; - Bytes.unsafe_set b_buffer (new_position - 1) c; - b.position <- new_position - -let add_char_string b c s = - let s_len = String.length s in - let len = s_len + 1 in - let new_position = b.position + len in - if new_position > b.length then resize b len; - let b_buffer = b.buffer in - let b_position = b.position in - Bytes.unsafe_set b_buffer b_position c ; - Ext_bytes.unsafe_blit_string s 0 b_buffer (b_position + 1) s_len; - b.position <- new_position - - -let add_bytes b s = add_string b (Bytes.unsafe_to_string s) - -let add_buffer b bs = - add_subbytes b bs.buffer 0 bs.position - -let add_channel b ic len = - if len < 0 - - || len > Sys.max_string_length - - then (* PR#5004 *) - invalid_arg "Ext_buffer.add_channel"; - if b.position + len > b.length then resize b len; - really_input ic b.buffer b.position len; - b.position <- b.position + len - -let output_buffer oc b = - output oc b.buffer 0 b.position - -external unsafe_string: bytes -> int -> int -> Digest.t = "caml_md5_string" - -let digest b = - unsafe_string - b.buffer 0 b.position - -let rec not_equal_aux (b : bytes) (s : string) i len = - if i >= len then false - else - (Bytes.unsafe_get b i - <> - String.unsafe_get s i ) - || not_equal_aux b s (i + 1) len - -(** avoid a large copy *) -let not_equal (b : t) (s : string) = - let b_len = b.position in - let s_len = String.length s in - b_len <> s_len - || not_equal_aux b.buffer s 0 s_len - - -(** - It could be one byte, two bytes, three bytes and four bytes - TODO: inline for better performance -*) -let add_int_1 (b : t ) (x : int ) = - let c = (Char.unsafe_chr (x land 0xff)) in - let pos = b.position in - if pos >= b.length then resize b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - -let add_int_2 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let pos = b.position in - if pos + 1 >= b.length then resize b 2; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - b.position <- pos + 2 - -let add_int_3 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in - let pos = b.position in - if pos + 2 >= b.length then resize b 3; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - Bytes.unsafe_set b_buffer (pos + 2) c3; - b.position <- pos + 3 - - -let add_int_4 (b : t ) (x : int ) = - let c1 = (Char.unsafe_chr (x land 0xff)) in - let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in - let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in - let c4 = (Char.unsafe_chr (x lsr 24 land 0xff)) in - let pos = b.position in - if pos + 3 >= b.length then resize b 4; - let b_buffer = b.buffer in - Bytes.unsafe_set b_buffer pos c1; - Bytes.unsafe_set b_buffer (pos + 1) c2; - Bytes.unsafe_set b_buffer (pos + 2) c3; - Bytes.unsafe_set b_buffer (pos + 3) c4; - b.position <- pos + 4 end -module Ext_filename : sig -#1 "ext_filename.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. +module Bsb_log : sig +#1 "bsb_log.mli" +(* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6223,69 +6043,31 @@ module Ext_filename : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +val setup : unit -> unit +type level = + | Debug + | Info + | Warn + | Error +val log_level : level ref -(* TODO: - Change the module name, this code is not really an extension of the standard - library but rather specific to JS Module name convention. -*) - - - - - -(** An extension module to calculate relative path follow node/npm style. - TODO : this short name will have to change upon renaming the file. -*) - -val is_dir_sep : - char -> bool - -val maybe_quote: - string -> - string - -val chop_extension_maybe: - string -> - string - -(* return an empty string if no extension found *) -val get_extension_maybe: - string -> - string - - -val new_extension: - string -> - string -> - string - -val chop_all_extensions_maybe: - string -> - string - -(* OCaml specific abstraction*) -val module_name: - string -> - string - - - +type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a -type module_info = { - module_name : string ; - case : bool; -} +type 'a log = ('a, Format.formatter, unit) format -> 'a +val verbose : unit -> unit +val debug : 'a log +val info : 'a log +val warn : 'a log +val error : 'a log +val info_args : string array -> unit -val as_module: - basename:string -> - module_info option end = struct -#1 "ext_filename.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. +#1 "bsb_log.ml" +(* Copyright (C) 2017- Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6311,7 +6093,542 @@ end = struct - +let ninja_ansi_forced = lazy + (try Sys.getenv "NINJA_ANSI_FORCED" with + Not_found ->"" + ) +let color_enabled = lazy (Unix.isatty Unix.stdout) + +(* same logic as [ninja.exe] *) +let get_color_enabled () = + let colorful = + match ninja_ansi_forced with + | lazy "1" -> true + | lazy ("0" | "false") -> false + | _ -> + Lazy.force color_enabled in + colorful + + + +let color_functions : Format.formatter_tag_functions = { + mark_open_tag = (fun s -> if get_color_enabled () then Ext_color.ansi_of_tag s else Ext_string.empty) ; + mark_close_tag = (fun _ -> if get_color_enabled () then Ext_color.reset_lit else Ext_string.empty); + print_open_tag = (fun _ -> ()); + print_close_tag = (fun _ -> ()) +} + +let set_color ppf = + Format.pp_set_formatter_tag_functions ppf color_functions + + +let setup () = + begin + Format.pp_set_mark_tags Format.std_formatter true ; + Format.pp_set_mark_tags Format.err_formatter true; + Format.pp_set_formatter_tag_functions + Format.std_formatter color_functions; + Format.pp_set_formatter_tag_functions + Format.err_formatter color_functions + end + +type level = + | Debug + | Info + | Warn + | Error + +let int_of_level (x : level) = + match x with + | Debug -> 0 + | Info -> 1 + | Warn -> 2 + | Error -> 3 + +let log_level = ref Warn + +let verbose () = + log_level := Debug +let dfprintf level fmt = + if int_of_level level >= int_of_level !log_level then + Format.fprintf fmt + else Format.ifprintf fmt + +type 'a fmt = + Format.formatter -> ('a, Format.formatter, unit) format -> 'a +type 'a log = + ('a, Format.formatter, unit) format -> 'a + +let debug fmt = dfprintf Debug Format.std_formatter fmt +let info fmt = dfprintf Info Format.std_formatter fmt +let warn fmt = dfprintf Warn Format.err_formatter fmt +let error fmt = dfprintf Error Format.err_formatter fmt + + +let info_args (args : string array) = + if int_of_level Info >= int_of_level !log_level then + begin + for i = 0 to Array.length args - 1 do + Format.pp_print_string Format.std_formatter (Array.unsafe_get args i) ; + Format.pp_print_string Format.std_formatter Ext_string.single_space; + done ; + Format.pp_print_newline Format.std_formatter () + end + else () + + +end +module Ext_buffer : sig +#1 "ext_buffer.mli" +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(** Extensible buffers. + + This module implements buffers that automatically expand + as necessary. It provides accumulative concatenation of strings + in quasi-linear time (instead of quadratic time when strings are + concatenated pairwise). +*) + +(* BuckleScript customization: customized for efficient digest *) + +type t +(** The abstract type of buffers. *) + +val create : int -> t +(** [create n] returns a fresh buffer, initially empty. + The [n] parameter is the initial size of the internal byte sequence + that holds the buffer contents. That byte sequence is automatically + reallocated when more than [n] characters are stored in the buffer, + but shrinks back to [n] characters when [reset] is called. + For best performance, [n] should be of the same order of magnitude + as the number of characters that are expected to be stored in + the buffer (for instance, 80 for a buffer that holds one output + line). Nothing bad will happen if the buffer grows beyond that + limit, however. In doubt, take [n = 16] for instance. + If [n] is not between 1 and {!Sys.max_string_length}, it will + be clipped to that interval. *) + +val contents : t -> string +(** Return a copy of the current contents of the buffer. + The buffer itself is unchanged. *) + +val length : t -> int +(** Return the number of characters currently contained in the buffer. *) + +val is_empty : t -> bool + +val clear : t -> unit +(** Empty the buffer. *) + + +val add_char : t -> char -> unit +(** [add_char b c] appends the character [c] at the end of the buffer [b]. *) + +val add_string : t -> string -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. *) + +val add_bytes : t -> bytes -> unit +(** [add_string b s] appends the string [s] at the end of the buffer [b]. + @since 4.02 *) + +val add_substring : t -> string -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in string [s] and appends them at the end of the buffer [b]. *) + +val add_subbytes : t -> bytes -> int -> int -> unit +(** [add_substring b s ofs len] takes [len] characters from offset + [ofs] in byte sequence [s] and appends them at the end of the buffer [b]. + @since 4.02 *) + +val add_buffer : t -> t -> unit +(** [add_buffer b1 b2] appends the current contents of buffer [b2] + at the end of buffer [b1]. [b2] is not modified. *) + +val add_channel : t -> in_channel -> int -> unit +(** [add_channel b ic n] reads exactly [n] character from the + input channel [ic] and stores them at the end of buffer [b]. + Raise [End_of_file] if the channel contains fewer than [n] + characters. *) + +val output_buffer : out_channel -> t -> unit +(** [output_buffer oc b] writes the current contents of buffer [b] + on the output channel [oc]. *) + +val digest : t -> Digest.t + +val not_equal : + t -> + string -> + bool + +val add_int_1 : + t -> int -> unit + +val add_int_2 : + t -> int -> unit + +val add_int_3 : + t -> int -> unit + +val add_int_4 : + t -> int -> unit + +val add_string_char : + t -> + string -> + char -> + unit + +val add_char_string : + t -> + char -> + string -> + unit +end = struct +#1 "ext_buffer.ml" +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Extensible buffers *) + +type t = + {mutable buffer : bytes; + mutable position : int; + mutable length : int; + initial_buffer : bytes} + +let create n = + let n = if n < 1 then 1 else n in + + let n = if n > Sys.max_string_length then Sys.max_string_length else n in + + let s = Bytes.create n in + {buffer = s; position = 0; length = n; initial_buffer = s} + +let contents b = Bytes.sub_string b.buffer 0 b.position +let to_bytes b = Bytes.sub b.buffer 0 b.position + +let sub b ofs len = + if ofs < 0 || len < 0 || ofs > b.position - len + then invalid_arg "Ext_buffer.sub" + else Bytes.sub_string b.buffer ofs len + + +let blit src srcoff dst dstoff len = + if len < 0 || srcoff < 0 || srcoff > src.position - len + || dstoff < 0 || dstoff > (Bytes.length dst) - len + then invalid_arg "Ext_buffer.blit" + else + Bytes.unsafe_blit src.buffer srcoff dst dstoff len + +let length b = b.position +let is_empty b = b.position = 0 +let clear b = b.position <- 0 + +let reset b = + b.position <- 0; b.buffer <- b.initial_buffer; + b.length <- Bytes.length b.buffer + +let resize b more = + let len = b.length in + let new_len = ref len in + while b.position + more > !new_len do new_len := 2 * !new_len done; + + if !new_len > Sys.max_string_length then begin + if b.position + more <= Sys.max_string_length + then new_len := Sys.max_string_length + else failwith "Ext_buffer.add: cannot grow buffer" + end; + + let new_buffer = Bytes.create !new_len in + (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in + this tricky function that is slow anyway. *) + Bytes.blit b.buffer 0 new_buffer 0 b.position; + b.buffer <- new_buffer; + b.length <- !new_len ; + assert (b.position + more <= b.length) + +let add_char b c = + let pos = b.position in + if pos >= b.length then resize b 1; + Bytes.unsafe_set b.buffer pos c; + b.position <- pos + 1 + +let add_substring b s offset len = + if offset < 0 || len < 0 || offset > String.length s - len + then invalid_arg "Ext_buffer.add_substring/add_subbytes"; + let new_position = b.position + len in + if new_position > b.length then resize b len; + Ext_bytes.unsafe_blit_string s offset b.buffer b.position len; + b.position <- new_position + + +let add_subbytes b s offset len = + add_substring b (Bytes.unsafe_to_string s) offset len + +let add_string b s = + let len = String.length s in + let new_position = b.position + len in + if new_position > b.length then resize b len; + Ext_bytes.unsafe_blit_string s 0 b.buffer b.position len; + b.position <- new_position + +(* TODO: micro-optimzie *) +let add_string_char b s c = + let s_len = String.length s in + let len = s_len + 1 in + let new_position = b.position + len in + if new_position > b.length then resize b len; + let b_buffer = b.buffer in + Ext_bytes.unsafe_blit_string s 0 b_buffer b.position s_len; + Bytes.unsafe_set b_buffer (new_position - 1) c; + b.position <- new_position + +let add_char_string b c s = + let s_len = String.length s in + let len = s_len + 1 in + let new_position = b.position + len in + if new_position > b.length then resize b len; + let b_buffer = b.buffer in + let b_position = b.position in + Bytes.unsafe_set b_buffer b_position c ; + Ext_bytes.unsafe_blit_string s 0 b_buffer (b_position + 1) s_len; + b.position <- new_position + + +let add_bytes b s = add_string b (Bytes.unsafe_to_string s) + +let add_buffer b bs = + add_subbytes b bs.buffer 0 bs.position + +let add_channel b ic len = + if len < 0 + + || len > Sys.max_string_length + + then (* PR#5004 *) + invalid_arg "Ext_buffer.add_channel"; + if b.position + len > b.length then resize b len; + really_input ic b.buffer b.position len; + b.position <- b.position + len + +let output_buffer oc b = + output oc b.buffer 0 b.position + +external unsafe_string: bytes -> int -> int -> Digest.t = "caml_md5_string" + +let digest b = + unsafe_string + b.buffer 0 b.position + +let rec not_equal_aux (b : bytes) (s : string) i len = + if i >= len then false + else + (Bytes.unsafe_get b i + <> + String.unsafe_get s i ) + || not_equal_aux b s (i + 1) len + +(** avoid a large copy *) +let not_equal (b : t) (s : string) = + let b_len = b.position in + let s_len = String.length s in + b_len <> s_len + || not_equal_aux b.buffer s 0 s_len + + +(** + It could be one byte, two bytes, three bytes and four bytes + TODO: inline for better performance +*) +let add_int_1 (b : t ) (x : int ) = + let c = (Char.unsafe_chr (x land 0xff)) in + let pos = b.position in + if pos >= b.length then resize b 1; + Bytes.unsafe_set b.buffer pos c; + b.position <- pos + 1 + +let add_int_2 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let pos = b.position in + if pos + 1 >= b.length then resize b 2; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + b.position <- pos + 2 + +let add_int_3 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in + let pos = b.position in + if pos + 2 >= b.length then resize b 3; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + Bytes.unsafe_set b_buffer (pos + 2) c3; + b.position <- pos + 3 + + +let add_int_4 (b : t ) (x : int ) = + let c1 = (Char.unsafe_chr (x land 0xff)) in + let c2 = (Char.unsafe_chr (x lsr 8 land 0xff)) in + let c3 = (Char.unsafe_chr (x lsr 16 land 0xff)) in + let c4 = (Char.unsafe_chr (x lsr 24 land 0xff)) in + let pos = b.position in + if pos + 3 >= b.length then resize b 4; + let b_buffer = b.buffer in + Bytes.unsafe_set b_buffer pos c1; + Bytes.unsafe_set b_buffer (pos + 1) c2; + Bytes.unsafe_set b_buffer (pos + 2) c3; + Bytes.unsafe_set b_buffer (pos + 3) c4; + b.position <- pos + 4 + + + + +end +module Ext_filename : sig +#1 "ext_filename.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + + + + +(* TODO: + Change the module name, this code is not really an extension of the standard + library but rather specific to JS Module name convention. +*) + + + + + +(** An extension module to calculate relative path follow node/npm style. + TODO : this short name will have to change upon renaming the file. +*) + +val is_dir_sep : + char -> bool + +val maybe_quote: + string -> + string + +val chop_extension_maybe: + string -> + string + +(* return an empty string if no extension found *) +val get_extension_maybe: + string -> + string + + +val new_extension: + string -> + string -> + string + +val chop_all_extensions_maybe: + string -> + string + +(* OCaml specific abstraction*) +val module_name: + string -> + string + + + + +type module_info = { + module_name : string ; + case : bool; +} + + + +val as_module: + basename:string -> + module_info option +end = struct +#1 "ext_filename.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + + + let is_dir_sep_unix c = c = '/' let is_dir_sep_win_cygwin c = c = '/' || c = '\\' || c = ':' @@ -6453,198 +6770,17 @@ let as_module ~basename = | Invalid -> None | Upper -> Some {module_name = Ext_string.capitalize_sub name i; case = true} - | Lower -> - Some {module_name = Ext_string.capitalize_sub name i; case = false} - else - search_dot (i - 1) name name_len in - let name_len = String.length basename in - search_dot (name_len - 1) basename name_len - -end -module Ext_namespace : sig -#1 "ext_namespace.mli" -(* Copyright (C) 2017- Authors of BuckleScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val make : ?ns:string -> string -> string -(** [make ~ns:"Ns" "a"] A typical example would return "a-Ns" Note the namespace - comes from the output of [namespace_of_package_name] *) - -val try_split_module_name : string -> (string * string) option - -val change_ext_ns_suffix : string -> string -> string - -type file_kind = Upper_js | Upper_bs | Little_js | Little_bs - -val js_name_of_modulename : string -> file_kind -> string -(** Predicts the JavaScript filename for a given (possibly namespaced) module- - name; i.e. [js_name_of_modulename "AA-Ns" Little_bs] would produce - ["aA.bs.js"]. *) - -val is_valid_npm_package_name : string -> bool - -val namespace_of_package_name : string -> string - -end = struct -#1 "ext_namespace.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Note the build system should check the validity of filenames espeically, it - should not contain '-' *) -let ns_sep_char = '-' -let ns_sep = "-" - -let make ?ns cunit = - match ns with - | None -> cunit - | Some ns -> cunit ^ ns_sep ^ ns - - -(** Starting from the end, search for [ns_sep_char]. Returns the index, if - found, or [-1] if [ns_sep_char] is not found before reaching a - directory-separator. *) -let rec rindex_rec s i = - if i < 0 then i - else - let char = String.unsafe_get s i in - if Ext_filename.is_dir_sep char then -1 - else if char = ns_sep_char then i - else rindex_rec s (i - 1) - - -(* Note we have to output uncapitalized file Name, or at least be consistent, - since by reading cmi file on Case insensitive OS, we don't really know - whether it is `list.cmi` or `List.cmi`, so that `require(./list.js)` or - `require(./List.js)`. Relevant issues: #1609, #913 - - #1933 when removing ns suffix, don't pass the bound of basename - - FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = - let i = rindex_rec name (String.length name - 1) in - if i < 0 then name ^ ext else String.sub name 0 i ^ ext - - -let try_split_module_name name = - let len = String.length name in - let i = rindex_rec name (len - 1) in - if i < 0 then None - else Some (String.sub name (i + 1) (len - i - 1), String.sub name 0 i) - - -type file_kind = Upper_js | Upper_bs | Little_js | Little_bs - -let js_name_of_modulename s little = - match little with - | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js - | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js - - -(** https://docs.npmjs.com/files/package.json - - Some rules: - - - The name must be less than or equal to 214 characters. This includes the - scope for scoped packages. - - The name can't start with a dot or an underscore. - - New packages must not have uppercase letters in the name. - - The name ends up being part of a URL, an argument on the command line, and - a folder name. Therefore, the name can't contain any non-URL-safe - characters. - - TODO: handle cases like '\@angular/core'. its directory structure is like: - - {[ - @angular - |-------- core - ]} *) -let is_valid_npm_package_name (s : string) = - let len = String.length s in - len <= 214 (* magic number forced by npm *) - && len > 0 - && - match String.unsafe_get s 0 with - | 'a' .. 'z' | '@' -> - Ext_string.for_all_from s 1 (fun x -> - match x with - | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true - | _ -> false) - | _ -> false - - -let namespace_of_package_name (s : string) : string = - let len = String.length s in - let buf = Ext_buffer.create len in - let add capital ch = - Ext_buffer.add_char buf (if capital then Char.uppercase_ascii ch else ch) - in - let rec aux capital off len = - if off >= len then () - else - let ch = String.unsafe_get s off in - match ch with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> - add capital ch; - aux false (off + 1) len - | '/' | '-' -> aux true (off + 1) len - | _ -> aux capital (off + 1) len - in - aux true 0 len; - Ext_buffer.contents buf - + | Lower -> + Some {module_name = Ext_string.capitalize_sub name i; case = false} + else + search_dot (i - 1) name name_len in + let name_len = String.length basename in + search_dot (name_len - 1) basename name_len + end -module Bsb_package_specs : sig -#1 "bsb_package_specs.mli" -(* Copyright (C) 2017 Authors of BuckleScript +module Ext_namespace : sig +#1 "ext_namespace.mli" +(* Copyright (C) 2017- Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6668,24 +6804,31 @@ module Bsb_package_specs : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type t +val make : ?ns:string -> string -> string +(** [make ~ns:"Ns" "a"] A typical example would return "a-Ns" Note the namespace + comes from the output of [namespace_of_package_name] *) -val default_package_specs : t +val try_split_module_name : string -> (string * string) option -val from_json : Ext_json_types.t -> t +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) -val get_list_of_output_js : t -> bool -> string -> string list +type file_kind = Upper_js | Upper_bs | Little_js | Little_bs -val package_flag_of_package_specs : t -> string -> string -(** Sample output: +val js_name_of_modulename : string -> file_kind -> string +(** Predicts the JavaScript filename for a given (possibly namespaced) module- + name; i.e. [js_name_of_modulename "AA-Ns" Little_bs] would produce + ["aA.bs.js"]. *) - {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) +val is_valid_npm_package_name : string -> bool -val list_dirs_by : t -> (string -> unit) -> unit +val namespace_of_package_name : string -> string end = struct -#1 "bsb_package_specs.ml" -(* Copyright (C) 2017 Authors of BuckleScript +#1 "ext_namespace.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -6709,200 +6852,121 @@ 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 ( // ) = Ext_path.combine - -(* TODO: sync up with {!Js_package_info.module_system} *) -type format = NodeJS | Es6 | Es6_global - -type spec = { format : format; in_source : bool } - -module Spec_set = Set.Make (struct - type t = spec - let compare = Pervasives.compare -end) - -type t = Spec_set.t - -let bad_module_format_message_exn ~loc format = - Bsb_exception.errorf ~loc - "package-specs: `%s` isn't a valid output module format. It has to be one \ - of: %s, %s or %s" - format Literals.commonjs Literals.es6 Literals.es6_global - - -let supported_format (x : string) loc = - if x = Literals.commonjs then NodeJS - else if x = Literals.es6 then Es6 - else if x = Literals.es6_global then Es6_global - else bad_module_format_message_exn ~loc x - - -let string_of_format (x : format) = - match x with - | NodeJS -> Literals.commonjs - | Es6 -> Literals.es6 - | Es6_global -> Literals.es6_global - - -let prefix_of_format (x : format) = - match x with - | NodeJS -> Bsb_config.lib_js - | Es6 -> Bsb_config.lib_es6 - | Es6_global -> Bsb_config.lib_es6_global - - -let rec from_array (arr : Ext_json_types.t array) : Spec_set.t = - let spec = ref Spec_set.empty in - let has_in_source = ref false in - Ext_array.iter arr (fun x -> - let result = from_json_single x in - if result.in_source then - if not !has_in_source then has_in_source := true - else - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: we've detected two module formats that are both \ - configured to be in-source."; - spec := Spec_set.add result !spec); - !spec - - -(* TODO: FIXME: better API without mutating *) -and from_json_single (x : Ext_json_types.t) : spec = - match x with - | Str { str = format; loc } -> - { format = supported_format format loc; in_source = false } - | Obj { map; loc } -> ( - match Map_string.find_exn map "module" with - | Str { str = format } -> - let in_source = - match Map_string.find_opt map Bsb_build_schemas.in_source with - | Some (True _) -> true - | Some _ | None -> false - in - { format = supported_format format loc; in_source } - | Arr _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, `module` \ - field should be a string, not an array. If you want to pass \ - multiple module specs, try turning package-specs into an array of \ - objects (or strings) instead." - | _ -> - Bsb_exception.errorf ~loc - "package-specs: the `module` field of the configuration object \ - should be a string." - | exception _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, the `module` \ - field is mandatory." ) - | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: we expect either a string or an object." - - -let from_json (x : Ext_json_types.t) : Spec_set.t = - match x with - | Arr { content; _ } -> from_array content - | _ -> Spec_set.singleton (from_json_single x) - +(* Note the build system should check the validity of filenames espeically, it + should not contain '-' *) +let ns_sep_char = '-' +let ns_sep = "-" -let bs_package_output = "-bs-package-output" +let make ?ns cunit = + match ns with + | None -> cunit + | Some ns -> cunit ^ ns_sep ^ ns -(** Assume input is valid - {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) -let package_flag ({ format; in_source } : spec) dir = - Ext_string.inter2 bs_package_output - (Ext_string.concat3 (string_of_format format) Ext_string.single_colon - (if in_source then dir else prefix_of_format format // dir)) +(** Starting from the end, search for [ns_sep_char]. Returns the index, if + found, or [-1] if [ns_sep_char] is not found before reaching a + directory-separator. *) +let rec rindex_rec s i = + if i < 0 then i + else + let char = String.unsafe_get s i in + if Ext_filename.is_dir_sep char then -1 + else if char = ns_sep_char then i + else rindex_rec s (i - 1) -let package_flag_of_package_specs (package_specs : t) (dirname : string) : - string = - Spec_set.fold - (fun format acc -> Ext_string.inter2 acc (package_flag format dirname)) - package_specs Ext_string.empty +(* Note we have to output uncapitalized file Name, or at least be consistent, + since by reading cmi file on Case insensitive OS, we don't really know + whether it is `list.cmi` or `List.cmi`, so that `require(./list.js)` or + `require(./List.js)`. Relevant issues: #1609, #913 + #1933 when removing ns suffix, don't pass the bound of basename -let default_package_specs = - Spec_set.singleton { format = NodeJS; in_source = false } + FIXME: micro-optimizaiton *) +let replace_namespace_with_extension ~name ~ext = + let i = rindex_rec name (String.length name - 1) in + if i < 0 then name ^ ext else String.sub name 0 i ^ ext -(** [get_list_of_output_js specs true "src/hi/hello"] *) -let get_list_of_output_js (package_specs : Spec_set.t) (bs_suffix : bool) - (output_file_sans_extension : string) = - Spec_set.fold - (fun (spec : spec) acc -> - let basename = - Ext_namespace.change_ext_ns_suffix output_file_sans_extension - (if bs_suffix then Literals.suffix_bs_js else Literals.suffix_js) - in - ( Bsb_config.proj_rel - @@ - if spec.in_source then basename - else prefix_of_format spec.format // basename ) - :: acc) - package_specs [] +let try_split_module_name name = + let len = String.length name in + let i = rindex_rec name (len - 1) in + if i < 0 then None + else Some (String.sub name (i + 1) (len - i - 1), String.sub name 0 i) -let list_dirs_by (package_specs : Spec_set.t) (f : string -> unit) = - Spec_set.iter - (fun (spec : spec) -> - if not spec.in_source then f (prefix_of_format spec.format)) - package_specs +type file_kind = Upper_js | Upper_bs | Little_js | Little_bs -end -module Bsc_warnings -= struct -#1 "bsc_warnings.ml" -(* Copyright (C) 2020- Authors of BuckleScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 +let js_name_of_modulename s little = + match little with + | Little_js -> + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js + | Little_bs -> + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +(** https://docs.npmjs.com/files/package.json + Some rules: -(** - See the meanings of the warning codes here: https://caml.inria.fr/pub/docs/manual-ocaml/comp.html#sec281 + - The name must be less than or equal to 214 characters. This includes the + scope for scoped packages. + - The name can't start with a dot or an underscore. + - New packages must not have uppercase letters in the name. + - The name ends up being part of a URL, an argument on the command line, and + a folder name. Therefore, the name can't contain any non-URL-safe + characters. - - 30 Two labels or constructors of the same name are defined in two mutually recursive types. - - 40 Constructor or label name used out of scope. + TODO: handle cases like '\@angular/core'. its directory structure is like: - - 6 Label omitted in function application. - - 7 Method overridden. - - 9 Missing fields in a record pattern. (*Not always desired, in some cases need [@@@warning "+9"] *) - - 27 Innocuous unused variable: unused variable that is not bound with let nor as, and doesn’t start with an underscore (_) character. - - 29 Unescaped end-of-line in a string constant (non-portable code). - - 32 .. 39 Unused blabla - - 44 Open statement shadows an already defined identifier. - - 45 Open statement shadows an already defined label or constructor. - - 48 Implicit elimination of optional arguments. https://caml.inria.fr/mantis/view.php?id=6352 - - 101 (bsb-specific) unsafe polymorphic comparison. -*) -let defaults_w = "-30-40+6+7+27+32..39+44+45+101" -let defaults_warn_error = "-a+5+101";; + {[ + @angular + |-------- core + ]} *) +let is_valid_npm_package_name (s : string) = + let len = String.length s in + len <= 214 (* magic number forced by npm *) + && len > 0 + && + match String.unsafe_get s 0 with + | 'a' .. 'z' | '@' -> + Ext_string.for_all_from s 1 (fun x -> + match x with + | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true + | _ -> false) + | _ -> false + + +let namespace_of_package_name (s : string) : string = + let len = String.length s in + let buf = Ext_buffer.create len in + let add capital ch = + Ext_buffer.add_char buf (if capital then Char.uppercase_ascii ch else ch) + in + let rec aux capital off len = + if off >= len then () + else + let ch = String.unsafe_get s off in + match ch with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> + add capital ch; + aux false (off + 1) len + | '/' | '-' -> aux true (off + 1) len + | _ -> aux capital (off + 1) len + in + aux true 0 len; + Ext_buffer.contents buf end -module Bsb_warning : sig -#1 "bsb_warning.mli" +module Bsb_package_specs : sig +#1 "bsb_package_specs.mli" (* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify @@ -6927,28 +6991,25 @@ module Bsb_warning : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +type t +val default_package_specs : t +val from_json : Ext_json_types.t -> t -type t - -(** Extra work is need to make merlin happy *) -val to_merlin_string : t -> string +val get_list_of_output_js : t -> string -> string list +val extract_in_source_bs_suffixes : t -> string list +val package_flag_of_package_specs : t -> string -> string +(** Sample output: -val from_map : Ext_json_types.t Map_string.t -> t + {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) -(** [to_bsb_string not_dev warning] -*) -val to_bsb_string : - toplevel:bool -> - t -> - string +val list_dirs_by : t -> (string -> unit) -> unit -val use_default : t end = struct -#1 "bsb_warning.ml" +#1 "bsb_package_specs.ml" (* Copyright (C) 2017 Authors of BuckleScript * * This program is free software: you can redistribute it and/or modify @@ -6973,199 +7034,204 @@ 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 ( // ) = Ext_path.combine -type warning_error = - | Warn_error_false - (* default [false] to make our changes non-intrusive *) - | Warn_error_true - | Warn_error_number of string +(* TODO: sync up with {!Js_package_info.module_system} *) +type format = NodeJS | Es6 | Es6_global -type t0 = { - number : string option; - error : warning_error -} +type spec = { format : format; in_source : bool; suffix : string } -type nonrec t = t0 option +module Spec_set = Set.Make (struct + type t = spec + let compare = Pervasives.compare +end) -let use_default = None +type t = Spec_set.t -let prepare_warning_concat ~(beg : bool) s = - let s = Ext_string.trim s in - if s = "" then s - else - match s.[0] with - | '0' .. '9' -> if beg then "-w +" ^ s else "+" ^ s - | 'a' .. 'z' -> - if beg then "-w " ^ s else "+" ^ s - | _ -> - if beg then "-w " ^ s else s +let bad_module_format_message_exn ~loc format = + Bsb_exception.errorf ~loc + "package-specs: `%s` isn't a valid output module format. It has to be one \ + of: %s, %s or %s" + format Literals.commonjs Literals.es6 Literals.es6_global -let to_merlin_string x = - "-w " ^ Bsc_warnings.defaults_w - ^ - (match x with - | Some {number =None} - | None -> Ext_string.empty - | Some {number = Some x} -> - prepare_warning_concat ~beg:false x ) +let supported_format (x : string) loc = + if x = Literals.commonjs then NodeJS + else if x = Literals.es6 then Es6 + else if x = Literals.es6_global then Es6_global + else bad_module_format_message_exn ~loc x - -let from_map (m : Ext_json_types.t Map_string.t) = - let number_opt = Map_string.find_opt m Bsb_build_schemas.number in - let error_opt = Map_string.find_opt m Bsb_build_schemas.error in - match number_opt, error_opt with - | None, None -> None - | _, _ -> - let error = - match error_opt with - | Some (True _) -> Warn_error_true - | Some (False _) -> Warn_error_false - | Some (Str {str ; }) - -> Warn_error_number str - | Some x -> Bsb_exception.config_error x "expect true/false or string" - | None -> Warn_error_false - (** To make it less intrusive : warning error has to be enabled*) - in - let number = - match number_opt with - | Some (Str { str = number}) -> Some number - | None -> None - | Some x -> Bsb_exception.config_error x "expect a string" - in - Some {number; error } -let to_bsb_string ~toplevel warning = - match warning with - | None -> Ext_string.empty - | Some warning -> - (match warning.number with - | None -> - Ext_string.empty - | Some x -> - prepare_warning_concat ~beg:true x - ) ^ - if toplevel then - match warning.error with - | Warn_error_true -> - " -warn-error A" - | Warn_error_number y -> - " -warn-error " ^ y - | Warn_error_false -> - Ext_string.empty - else Ext_string.empty +let string_of_format (x : format) = + match x with + | NodeJS -> Literals.commonjs + | Es6 -> Literals.es6 + | Es6_global -> Literals.es6_global -end -module Bs_hash_stubs -= struct -#1 "bs_hash_stubs.ml" +let prefix_of_format (x : format) = + match x with + | NodeJS -> Bsb_config.lib_js + | Es6 -> Bsb_config.lib_es6 + | Es6_global -> Bsb_config.lib_es6_global -external hash_string : string -> int = "caml_bs_hash_string" [@@noalloc];; +let bad_suffix_message_warn suffix = + Bsb_log.warn + "@{UNSUPPORTED@}: package-specs: extension `%s` is unsupported@;\ + ; consider one of: %s, %s, %s, or %s@." suffix Literals.suffix_js + Literals.suffix_mjs Literals.suffix_bs_js Literals.suffix_bs_mjs -external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" [@@noalloc];; -external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" [@@noalloc];; +let supported_suffix (x : string) = + if not (List.mem x Literals.[ suffix_js; suffix_bs_js; suffix_bs_mjs ]) then + bad_suffix_message_warn x; + x -external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" [@@noalloc];; -external hash_small_int : int -> int = "caml_bs_hash_small_int" [@@noalloc];; +let default_suffix format in_source = + (* In the absence of direction to the contrary, the suffix depends on + * [format] and [in_source]. *) + match (format, in_source) with + | NodeJS, false -> Literals.suffix_js + | NodeJS, true -> Literals.suffix_bs_js + | _, false -> Literals.suffix_mjs + | _, true -> Literals.suffix_bs_mjs -external hash_int : int -> int = "caml_bs_hash_int" [@@noalloc];; -external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];; +module SS = Set.Make (String) -external - int_unsafe_blit : - int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" [@@noalloc];; +let supported_bs_suffixes = Literals.[ suffix_bs_js; suffix_bs_mjs ] - +(** Produces a [list] of supported, bs-prefixed file-suffixes used in + [in-source] package-specs. *) +let extract_in_source_bs_suffixes (package_specs : Spec_set.t) = + let f spec suffixes = + if spec.in_source && List.mem spec.suffix supported_bs_suffixes then + SS.add spec.suffix suffixes + else suffixes + in + let suffixes = Spec_set.fold f package_specs SS.empty in + SS.elements suffixes -end -module Ext_util : sig -#1 "ext_util.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let rec from_array (arr : Ext_json_types.t array) : Spec_set.t = + let spec = ref Spec_set.empty in + let has_in_source = ref false in + Ext_array.iter arr (fun x -> + let result = from_json_single x in + if result.in_source then + if not !has_in_source then has_in_source := true + else + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "package-specs: we've detected two module formats that are both \ + configured to be in-source."; + spec := Spec_set.add result !spec); + !spec + + +(* TODO: FIXME: better API without mutating *) +and from_json_single (x : Ext_json_types.t) : spec = + match x with + | Str { str = format; loc } -> + let format = supported_format format loc in + { format; in_source = false; suffix = default_suffix format false } + | Obj { map; loc } -> ( + match Map_string.find_exn map Bsb_build_schemas._module with + | Str { str = format } -> + let format = supported_format format loc in + let in_source = + match Map_string.find_opt map Bsb_build_schemas.in_source with + | Some (True _) -> true + | Some _ | None -> false + in + let suffix = + match Map_string.find_opt map Bsb_build_schemas.suffix with + | Some (Str { str = suffix; loc }) -> supported_suffix suffix + | Some _ -> + Bsb_exception.errorf ~loc + "package-specs: the `suffix` field of the configuration \ + object must be absent, or a string." + | None -> default_suffix format in_source + in + { format; in_source; suffix } + | Arr _ -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, `module` \ + field should be a string, not an array. If you want to pass \ + multiple module specs, try turning package-specs into an array of \ + objects (or strings) instead." + | _ -> + Bsb_exception.errorf ~loc + "package-specs: the `module` field of the configuration object \ + should be a string." + | exception _ -> + Bsb_exception.errorf ~loc + "package-specs: when the configuration is an object, the `module` \ + field is mandatory." ) + | _ -> + Bsb_exception.errorf ~loc:(Ext_json.loc_of x) + "package-specs: we expect either a string or an object." + + +let from_json (x : Ext_json_types.t) : Spec_set.t = + match x with + | Arr { content; _ } -> from_array content + | _ -> Spec_set.singleton (from_json_single x) + + +let bs_package_output = "-bs-package-output" + +(** Assume input is valid + + {[ -bs-package-output commonjs:lib/js/jscomp/test ]} *) +let package_flag ({ format; in_source } : spec) dir = + Ext_string.inter2 bs_package_output + (Ext_string.concat3 (string_of_format format) Ext_string.single_colon + (if in_source then dir else prefix_of_format format // dir)) - -val power_2_above : int -> int -> int +let package_flag_of_package_specs (package_specs : t) (dirname : string) : + string = + Spec_set.fold + (fun format acc -> Ext_string.inter2 acc (package_flag format dirname)) + package_specs Ext_string.empty -val stats_to_string : Hashtbl.statistics -> string -end = struct -#1 "ext_util.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +let default_package_specs = + Spec_set.singleton + { format = NodeJS; in_source = false; suffix = default_suffix NodeJS false } -(** - {[ - (power_2_above 16 63 = 64) - (power_2_above 16 76 = 128) - ]} -*) -let rec power_2_above x n = - if x >= n then x - else if x * 2 > Sys.max_array_length then x - else power_2_above (x * 2) n + +(** [get_list_of_output_js specs true "src/hi/hello"] *) +let get_list_of_output_js (package_specs : Spec_set.t) + (output_file_sans_extension : string) = + Spec_set.fold + (fun spec acc -> + let basename = + Ext_namespace.replace_namespace_with_extension + ~name:output_file_sans_extension ~ext:spec.suffix + in + ( Bsb_config.proj_rel + @@ + if spec.in_source then basename + else prefix_of_format spec.format // basename ) + :: acc) + package_specs [] -let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = - Printf.sprintf - "bindings: %d,buckets: %d, longest: %d, hist:[%s]" - num_bindings - num_buckets - max_bucket_length - (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +let list_dirs_by (package_specs : Spec_set.t) (f : string -> unit) = + Spec_set.iter + (fun (spec : spec) -> + if not spec.in_source then f (prefix_of_format spec.format)) + package_specs + end -module Hash_set_gen +module Bsc_warnings = struct -#1 "hash_set_gen.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +#1 "bsc_warnings.ml" +(* Copyright (C) 2020- Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7182,174 +7248,39 @@ module Hash_set_gen * This program 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 Lesser General Public License for more details. - * + + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. *) - -type 'a bucket = - | Empty - | Cons of { - mutable key : 'a ; - mutable next : 'a bucket - } - -type 'a t = - { mutable size: int; (* number of entries *) - mutable data: 'a bucket array; (* the buckets *) - initial_size: int; (* initial array size *) - } - - - - -let create initial_size = - let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } - -let clear h = - h.size <- 0; - let len = Array.length h.data in - for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty - done - -let reset h = - h.size <- 0; - h.data <- Array.make h.initial_size Empty - -let length h = h.size - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin - let ndata = Array.make nsize Empty in - let ndata_tail = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - Empty -> () - | Cons {key; next} as cell -> - let nidx = indexfun h key in - begin match Array.unsafe_get ndata_tail nidx with - | Empty -> - Array.unsafe_set ndata nidx cell - | Cons tail -> - tail.next <- cell - end; - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done; - for i = 0 to nsize - 1 do - match Array.unsafe_get ndata_tail i with - | Empty -> () - | Cons tail -> tail.next <- Empty - done - end - -let iter h f = - let rec do_bucket = function - | Empty -> - () - | Cons l -> - f l.key ; do_bucket l.next in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) - done - -let fold h init f = - let rec do_bucket b accu = - match b with - Empty -> - accu - | Cons l -> - do_bucket l.next (f l.key accu) in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu - done; - !accu - - -let elements set = - fold set [] List.cons - - - - -let rec small_bucket_mem eq key lst = - match lst with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - match lst.next with - | Empty -> false - | Cons lst -> - eq key lst.key || - small_bucket_mem eq key lst.next - -let rec remove_bucket - (h : _ t) (i : int) - key - ~(prec : _ bucket) - (buck : _ bucket) - eq_key = - match buck with - | Empty -> - () - | Cons {key=k; next } -> - if eq_key k key - then begin - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next - end - else remove_bucket h i key ~prec:buck next eq_key - - -module type S = -sig - type key - type t - val create: int -> t - val clear : t -> unit - val reset : t -> unit - (* val copy: t -> t *) - val remove: t -> key -> unit - val add : t -> key -> unit - val of_array : key array -> t - val check_add : t -> key -> bool - val mem : t -> key -> bool - val iter: t -> (key -> unit) -> unit - val fold: t -> 'b -> (key -> 'b -> 'b) -> 'b - val length: t -> int - (* val stats: t -> Hashtbl.statistics *) - val elements : t -> key list -end +(** + See the meanings of the warning codes here: https://caml.inria.fr/pub/docs/manual-ocaml/comp.html#sec281 + - 30 Two labels or constructors of the same name are defined in two mutually recursive types. + - 40 Constructor or label name used out of scope. -end -module Hash_set_string : sig -#1 "hash_set_string.mli" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + - 6 Label omitted in function application. + - 7 Method overridden. + - 9 Missing fields in a record pattern. (*Not always desired, in some cases need [@@@warning "+9"] *) + - 27 Innocuous unused variable: unused variable that is not bound with let nor as, and doesn’t start with an underscore (_) character. + - 29 Unescaped end-of-line in a string constant (non-portable code). + - 32 .. 39 Unused blabla + - 44 Open statement shadows an already defined identifier. + - 45 Open statement shadows an already defined label or constructor. + - 48 Implicit elimination of optional arguments. https://caml.inria.fr/mantis/view.php?id=6352 + - 101 (bsb-specific) unsafe polymorphic comparison. +*) +let defaults_w = "-30-40+6+7+27+32..39+44+45+101" +let defaults_warn_error = "-a+5+101";; + +end +module Bsb_warning : sig +#1 "bsb_warning.mli" +(* Copyright (C) 2017 Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7367,19 +7298,35 @@ module Hash_set_string : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Hash_set_gen.S with type key = string + +type t + +(** Extra work is need to make merlin happy *) +val to_merlin_string : t -> string + + + +val from_map : Ext_json_types.t Map_string.t -> t + +(** [to_bsb_string not_dev warning] +*) +val to_bsb_string : + toplevel:bool -> + t -> + string + +val use_default : t end = struct -#1 "hash_set_string.ml" -# 1 "ext/hash_set.cppo.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * +#1 "bsb_warning.ml" +(* Copyright (C) 2017 Authors of BuckleScript + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -7397,170 +7344,123 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -# 31 "ext/hash_set.cppo.ml" -type key = string -let key_index (h : _ Hash_set_gen.t ) (key : key) = - (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1) -let eq_key = Ext_string.equal -type t = key Hash_set_gen.t -# 64 "ext/hash_set.cppo.ml" -let create = Hash_set_gen.create -let clear = Hash_set_gen.clear -let reset = Hash_set_gen.reset -(* let copy = Hash_set_gen.copy *) -let iter = Hash_set_gen.iter -let fold = Hash_set_gen.fold -let length = Hash_set_gen.length -(* let stats = Hash_set_gen.stats *) -let elements = Hash_set_gen.elements - +type warning_error = + | Warn_error_false + (* default [false] to make our changes non-intrusive *) + | Warn_error_true + | Warn_error_number of string +type t0 = { + number : string option; + error : warning_error +} -let remove (h : _ Hash_set_gen.t ) key = - let i = key_index h key in - let h_data = h.data in - Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key +type nonrec t = t0 option +let use_default = None +let prepare_warning_concat ~(beg : bool) s = + let s = Ext_string.trim s in + if s = "" then s + else + match s.[0] with + | '0' .. '9' -> if beg then "-w +" ^ s else "+" ^ s + | 'a' .. 'z' -> + if beg then "-w " ^ s else "+" ^ s + | _ -> + if beg then "-w " ^ s else s -let add (h : _ Hash_set_gen.t) key = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h - end +let to_merlin_string x = + "-w " ^ Bsc_warnings.defaults_w + ^ + (match x with + | Some {number =None} + | None -> Ext_string.empty + | Some {number = Some x} -> + prepare_warning_concat ~beg:false x ) -let of_array arr = - let len = Array.length arr in - let tbl = create len in - for i = 0 to len - 1 do - add tbl (Array.unsafe_get arr i); - done ; - tbl - - -let check_add (h : _ Hash_set_gen.t) key : bool = - let i = key_index h key in - let h_data = h.data in - let old_bucket = (Array.unsafe_get h_data i) in - if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then - begin - Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; - true - end - else false + +let from_map (m : Ext_json_types.t Map_string.t) = + let number_opt = Map_string.find_opt m Bsb_build_schemas.number in + let error_opt = Map_string.find_opt m Bsb_build_schemas.error in + match number_opt, error_opt with + | None, None -> None + | _, _ -> + let error = + match error_opt with + | Some (True _) -> Warn_error_true + | Some (False _) -> Warn_error_false + | Some (Str {str ; }) + -> Warn_error_number str + | Some x -> Bsb_exception.config_error x "expect true/false or string" + | None -> Warn_error_false + (** To make it less intrusive : warning error has to be enabled*) + in + let number = + match number_opt with + | Some (Str { str = number}) -> Some number + | None -> None + | Some x -> Bsb_exception.config_error x "expect a string" + in + Some {number; error } -let mem (h : _ Hash_set_gen.t) key = - Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) +let to_bsb_string ~toplevel warning = + match warning with + | None -> Ext_string.empty + | Some warning -> + (match warning.number with + | None -> + Ext_string.empty + | Some x -> + prepare_warning_concat ~beg:true x + ) ^ + if toplevel then + match warning.error with + | Warn_error_true -> + " -warn-error A" + | Warn_error_number y -> + " -warn-error " ^ y + | Warn_error_false -> + Ext_string.empty + else Ext_string.empty - end -module Bsb_config_types +module Bs_hash_stubs = struct -#1 "bsb_config_types.ml" -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program 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 Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +#1 "bs_hash_stubs.ml" -type dependency = - { - package_name : Bsb_pkg_types.t ; - package_install_path : string ; - } -type dependencies = dependency list +external hash_string : string -> int = "caml_bs_hash_string" [@@noalloc];; -(* `string` is a path to the entrypoint *) -type entries_t = JsTarget of string | NativeTarget of string | BytecodeTarget of string +external hash_string_int : string -> int -> int = "caml_bs_hash_string_and_int" [@@noalloc];; -type compilation_kind_t = Js | Bytecode | Native +external hash_string_small_int : string -> int -> int = "caml_bs_hash_string_and_small_int" [@@noalloc];; -type reason_react_jsx = - | Jsx_v2 - | Jsx_v3 - (* string option *) +external hash_stamp_and_name : int -> string -> int = "caml_bs_hash_stamp_and_name" [@@noalloc];; -type refmt = string option +external hash_small_int : int -> int = "caml_bs_hash_small_int" [@@noalloc];; -type gentype_config = { - path : string (* resolved *) -} -type command = string +external hash_int : int -> int = "caml_bs_hash_int" [@@noalloc];; -type ppx = { - name : string; - args : string list -} -type t = - { - package_name : string ; - (* [captial-package] *) - namespace : string option; - (* CapitalPackage *) - external_includes : string list ; - bsc_flags : string list ; - ppx_files : ppx list ; - pp_file : string option; - bs_dependencies : dependencies; - bs_dev_dependencies : dependencies; - built_in_dependency : dependency option; - warning : Bsb_warning.t; - (*TODO: maybe we should always resolve bs-platform - so that we can calculate correct relative path in - [.merlin] - *) - refmt : refmt; - js_post_build_cmd : string option; - package_specs : Bsb_package_specs.t ; - file_groups : Bsb_file_groups.t; - files_to_install : Hash_set_string.t ; - generate_merlin : bool ; - reason_react_jsx : reason_react_jsx option; (* whether apply PPX transform or not*) - entries : entries_t list ; - generators : command Map_string.t ; - cut_generators : bool; (* note when used as a dev mode, we will always ignore it *) - bs_suffix : bool ; (* true means [.bs.js] we should pass [-bs-suffix] flag *) - gentype_config : gentype_config option; - number_of_dev_groups : int - } +external string_length_based_compare : string -> string -> int = "caml_string_length_based_compare" [@@noalloc];; + +external + int_unsafe_blit : + int array -> int -> int array -> int -> int -> unit = "caml_int_array_blit" [@@noalloc];; + + end -module Ext_color : sig -#1 "ext_color.mli" +module Ext_util : sig +#1 "ext_util.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -7585,29 +7485,14 @@ module Ext_color : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type color - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - -type style - = FG of color - | BG of color - | Bold - | Dim -(** Input is the tag for example `@{@}` return escape code *) -val ansi_of_tag : string -> string + +val power_2_above : int -> int -> int -val reset_lit : string +val stats_to_string : Hashtbl.statistics -> string end = struct -#1 "ext_color.ml" +#1 "ext_util.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -7632,86 +7517,214 @@ 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. *) +(** + {[ + (power_2_above 16 63 = 64) + (power_2_above 16 76 = 128) + ]} +*) +let rec power_2_above x n = + if x >= n then x + else if x * 2 > Sys.max_array_length then x + else power_2_above (x * 2) n + +let stats_to_string ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = + Printf.sprintf + "bindings: %d,buckets: %d, longest: %d, hist:[%s]" + num_bindings + num_buckets + max_bucket_length + (String.concat "," (Array.to_list (Array.map string_of_int bucket_histogram))) +end +module Hash_set_gen += struct +#1 "hash_set_gen.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type color - = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) -type style - = FG of color - | BG of color - | Bold - | Dim +type 'a bucket = + | Empty + | Cons of { + mutable key : 'a ; + mutable next : 'a bucket + } +type 'a t = + { mutable size: int; (* number of entries *) + mutable data: 'a bucket array; (* the buckets *) + initial_size: int; (* initial array size *) + } -let ansi_of_color = function - | Black -> "0" - | Red -> "1" - | Green -> "2" - | Yellow -> "3" - | Blue -> "4" - | Magenta -> "5" - | Cyan -> "6" - | White -> "7" -let code_of_style = function - | FG Black -> "30" - | FG Red -> "31" - | FG Green -> "32" - | FG Yellow -> "33" - | FG Blue -> "34" - | FG Magenta -> "35" - | FG Cyan -> "36" - | FG White -> "37" - - | BG Black -> "40" - | BG Red -> "41" - | BG Green -> "42" - | BG Yellow -> "43" - | BG Blue -> "44" - | BG Magenta -> "45" - | BG Cyan -> "46" - | BG White -> "47" - | Bold -> "1" - | Dim -> "2" +let create initial_size = + let s = Ext_util.power_2_above 16 initial_size in + { initial_size = s; size = 0; data = Array.make s Empty } +let clear h = + h.size <- 0; + let len = Array.length h.data in + for i = 0 to len - 1 do + Array.unsafe_set h.data i Empty + done -(** TODO: add more styles later *) -let style_of_tag s = match s with - | "error" -> [Bold; FG Red] - | "warning" -> [Bold; FG Magenta] - | "info" -> [Bold; FG Yellow] - | "dim" -> [Dim] - | "filename" -> [FG Cyan] - | _ -> [] +let reset h = + h.size <- 0; + h.data <- Array.make h.initial_size Empty -let ansi_of_tag s = - let l = style_of_tag s in - let s = String.concat ";" (Ext_list.map l code_of_style) in - "\x1b[" ^ s ^ "m" +let length h = h.size + +let resize indexfun h = + let odata = h.data in + let osize = Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then begin + let ndata = Array.make nsize Empty in + let ndata_tail = Array.make nsize Empty in + h.data <- ndata; (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + Empty -> () + | Cons {key; next} as cell -> + let nidx = indexfun h key in + begin match Array.unsafe_get ndata_tail nidx with + | Empty -> + Array.unsafe_set ndata nidx cell + | Cons tail -> + tail.next <- cell + end; + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next + in + for i = 0 to osize - 1 do + insert_bucket (Array.unsafe_get odata i) + done; + for i = 0 to nsize - 1 do + match Array.unsafe_get ndata_tail i with + | Empty -> () + | Cons tail -> tail.next <- Empty + done + end + +let iter h f = + let rec do_bucket = function + | Empty -> + () + | Cons l -> + f l.key ; do_bucket l.next in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket (Array.unsafe_get d i) + done + +let fold h init f = + let rec do_bucket b accu = + match b with + Empty -> + accu + | Cons l -> + do_bucket l.next (f l.key accu) in + let d = h.data in + let accu = ref init in + for i = 0 to Array.length d - 1 do + accu := do_bucket (Array.unsafe_get d i) !accu + done; + !accu +let elements set = + fold set [] List.cons -let reset_lit = "\x1b[0m" +let rec small_bucket_mem eq key lst = + match lst with + | Empty -> false + | Cons lst -> + eq key lst.key || + match lst.next with + | Empty -> false + | Cons lst -> + eq key lst.key || + match lst.next with + | Empty -> false + | Cons lst -> + eq key lst.key || + small_bucket_mem eq key lst.next + +let rec remove_bucket + (h : _ t) (i : int) + key + ~(prec : _ bucket) + (buck : _ bucket) + eq_key = + match buck with + | Empty -> + () + | Cons {key=k; next } -> + if eq_key k key + then begin + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next + end + else remove_bucket h i key ~prec:buck next eq_key + + +module type S = +sig + type key + type t + val create: int -> t + val clear : t -> unit + val reset : t -> unit + (* val copy: t -> t *) + val remove: t -> key -> unit + val add : t -> key -> unit + val of_array : key array -> t + val check_add : t -> key -> bool + val mem : t -> key -> bool + val iter: t -> (key -> unit) -> unit + val fold: t -> 'b -> (key -> 'b -> 'b) -> 'b + val length: t -> int + (* val stats: t -> Hashtbl.statistics *) + val elements : t -> key list +end + end -module Bsb_log : sig -#1 "bsb_log.mli" -(* Copyright (C) 2017 Authors of BuckleScript +module Hash_set_string : sig +#1 "hash_set_string.mli" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -7736,31 +7749,12 @@ module Bsb_log : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val setup : unit -> unit - -type level = - | Debug - | Info - | Warn - | Error - -val log_level : level ref - -type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a - -type 'a log = ('a, Format.formatter, unit) format -> 'a - -val verbose : unit -> unit -val debug : 'a log -val info : 'a log -val warn : 'a log -val error : 'a log - -val info_args : string array -> unit +include Hash_set_gen.S with type key = string end = struct -#1 "bsb_log.ml" -(* Copyright (C) 2017- Authors of BuckleScript +#1 "hash_set_string.ml" +# 1 "ext/hash_set.cppo.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by @@ -7783,92 +7777,161 @@ end = struct * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +# 31 "ext/hash_set.cppo.ml" +type key = string +let key_index (h : _ Hash_set_gen.t ) (key : key) = + (Bs_hash_stubs.hash_string key) land (Array.length h.data - 1) +let eq_key = Ext_string.equal +type t = key Hash_set_gen.t +# 64 "ext/hash_set.cppo.ml" +let create = Hash_set_gen.create +let clear = Hash_set_gen.clear +let reset = Hash_set_gen.reset +(* let copy = Hash_set_gen.copy *) +let iter = Hash_set_gen.iter +let fold = Hash_set_gen.fold +let length = Hash_set_gen.length +(* let stats = Hash_set_gen.stats *) +let elements = Hash_set_gen.elements -let ninja_ansi_forced = lazy - (try Sys.getenv "NINJA_ANSI_FORCED" with - Not_found ->"" - ) -let color_enabled = lazy (Unix.isatty Unix.stdout) -(* same logic as [ninja.exe] *) -let get_color_enabled () = - let colorful = - match ninja_ansi_forced with - | lazy "1" -> true - | lazy ("0" | "false") -> false - | _ -> - Lazy.force color_enabled in - colorful +let remove (h : _ Hash_set_gen.t ) key = + let i = key_index h key in + let h_data = h.data in + Hash_set_gen.remove_bucket h i key ~prec:Empty (Array.unsafe_get h_data i) eq_key -let color_functions : Format.formatter_tag_functions = { - mark_open_tag = (fun s -> if get_color_enabled () then Ext_color.ansi_of_tag s else Ext_string.empty) ; - mark_close_tag = (fun _ -> if get_color_enabled () then Ext_color.reset_lit else Ext_string.empty); - print_open_tag = (fun _ -> ()); - print_close_tag = (fun _ -> ()) -} -let set_color ppf = - Format.pp_set_formatter_tag_functions ppf color_functions +let add (h : _ Hash_set_gen.t) key = + let i = key_index h key in + let h_data = h.data in + let old_bucket = (Array.unsafe_get h_data i) in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then + begin + Array.unsafe_set h_data i (Cons {key = key ; next = old_bucket}); + h.size <- h.size + 1 ; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h + end +let of_array arr = + let len = Array.length arr in + let tbl = create len in + for i = 0 to len - 1 do + add tbl (Array.unsafe_get arr i); + done ; + tbl + + +let check_add (h : _ Hash_set_gen.t) key : bool = + let i = key_index h key in + let h_data = h.data in + let old_bucket = (Array.unsafe_get h_data i) in + if not (Hash_set_gen.small_bucket_mem eq_key key old_bucket) then + begin + Array.unsafe_set h_data i (Cons { key = key ; next = old_bucket}); + h.size <- h.size + 1 ; + if h.size > Array.length h_data lsl 1 then Hash_set_gen.resize key_index h; + true + end + else false -let setup () = - begin - Format.pp_set_mark_tags Format.std_formatter true ; - Format.pp_set_mark_tags Format.err_formatter true; - Format.pp_set_formatter_tag_functions - Format.std_formatter color_functions; - Format.pp_set_formatter_tag_functions - Format.err_formatter color_functions - end -type level = - | Debug - | Info - | Warn - | Error +let mem (h : _ Hash_set_gen.t) key = + Hash_set_gen.small_bucket_mem eq_key key (Array.unsafe_get h.data (key_index h key)) -let int_of_level (x : level) = - match x with - | Debug -> 0 - | Info -> 1 - | Warn -> 2 - | Error -> 3 + -let log_level = ref Warn +end +module Bsb_config_types += struct +#1 "bsb_config_types.ml" +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program 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 Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let verbose () = - log_level := Debug -let dfprintf level fmt = - if int_of_level level >= int_of_level !log_level then - Format.fprintf fmt - else Format.ifprintf fmt -type 'a fmt = - Format.formatter -> ('a, Format.formatter, unit) format -> 'a -type 'a log = - ('a, Format.formatter, unit) format -> 'a +type dependency = + { + package_name : Bsb_pkg_types.t ; + package_install_path : string ; + } +type dependencies = dependency list -let debug fmt = dfprintf Debug Format.std_formatter fmt -let info fmt = dfprintf Info Format.std_formatter fmt -let warn fmt = dfprintf Warn Format.err_formatter fmt -let error fmt = dfprintf Error Format.err_formatter fmt +(* `string` is a path to the entrypoint *) +type entries_t = JsTarget of string | NativeTarget of string | BytecodeTarget of string +type compilation_kind_t = Js | Bytecode | Native -let info_args (args : string array) = - if int_of_level Info >= int_of_level !log_level then - begin - for i = 0 to Array.length args - 1 do - Format.pp_print_string Format.std_formatter (Array.unsafe_get args i) ; - Format.pp_print_string Format.std_formatter Ext_string.single_space; - done ; - Format.pp_print_newline Format.std_formatter () - end - else () - +type reason_react_jsx = + | Jsx_v2 + | Jsx_v3 + (* string option *) + +type refmt = string option + +type gentype_config = { + path : string (* resolved *) +} +type command = string + +type ppx = { + name : string; + args : string list +} +type t = + { + package_name : string ; + (* [captial-package] *) + namespace : string option; + (* CapitalPackage *) + external_includes : string list ; + bsc_flags : string list ; + ppx_files : ppx list ; + pp_file : string option; + bs_dependencies : dependencies; + bs_dev_dependencies : dependencies; + built_in_dependency : dependency option; + warning : Bsb_warning.t; + (*TODO: maybe we should always resolve bs-platform + so that we can calculate correct relative path in + [.merlin] + *) + refmt : refmt; + js_post_build_cmd : string option; + package_specs : Bsb_package_specs.t ; + file_groups : Bsb_file_groups.t; + files_to_install : Hash_set_string.t ; + generate_merlin : bool ; + reason_react_jsx : reason_react_jsx option; (* whether apply PPX transform or not*) + entries : entries_t list ; + generators : command Map_string.t ; + cut_generators : bool; (* note when used as a dev mode, we will always ignore it *) + gentype_config : gentype_config option; + number_of_dev_groups : int + } end module Bsb_real_path : sig @@ -10233,7 +10296,7 @@ val scan : root:string -> cut_generators:bool -> namespace:string option -> - bs_suffix:bool -> + bs_suffixes:string list -> ignored_dirs:Set_string.t -> Ext_json_types.t -> Bsb_file_groups.t * int @@ -10292,7 +10355,7 @@ type cxt = { cut_generators : bool; traverse : bool; namespace : string option; - bs_suffix : bool; + bs_suffixes : string list; ignored_dirs : Set_string.t; } @@ -10452,6 +10515,13 @@ let classify_suffix (x : string) : suffix_kind = if i >= 0 then Cmti i else Not_any +(** Attempt to delete any [.bs.m?js] files for a given artifact. *) +let unlink_bs_suffixes context artifact = + List.iter + (fun suffix -> try_unlink (Filename.concat context.cwd (artifact ^ suffix))) + context.bs_suffixes + + (* This is the only place where we do some removal during scanning, configurably. *) let prune_staled_bs_js_files (context : cxt) (cur_sources : _ Map_string.t) : @@ -10482,12 +10552,7 @@ let prune_staled_bs_js_files (context : cxt) (cur_sources : _ Map_string.t) : if cmd <> "" then Ext_pervasives.try_it (fun _ -> Sys.command (cmd ^ " -cmt-rm " ^ filepath)) - | Cmj _ -> - (* remove .bs.js *) - if context.bs_suffix then - try_unlink - (Filename.concat context.cwd - (String.sub x 0 j ^ Literals.suffix_bs_js)) + | Cmj _ -> unlink_bs_suffixes context (String.sub x 0 j) | _ -> () ); try_unlink filepath ) else () @@ -10647,8 +10712,8 @@ and parse_sources (cxt : cxt) (sources : Ext_json_types.t) = | _ -> parsing_single_source cxt sources -let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffix ~ignored_dirs x : - t * int = +let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffixes ~ignored_dirs x + : t * int = Bsb_dir_index.reset (); let output = parse_sources @@ -10660,7 +10725,7 @@ let scan ~toplevel ~root ~cut_generators ~namespace ~bs_suffix ~ignored_dirs x : root; cut_generators; namespace; - bs_suffix; + bs_suffixes; traverse = false; } x @@ -11273,17 +11338,6 @@ let check_stdlib (map : json_map) cwd (*built_in_package*) = | _ -> assert false ) -let extract_bs_suffix_exn (map : json_map) = - match Map_string.find_opt map Bsb_build_schemas.suffix with - | None -> false - | Some (Str { str } as config) -> - if str = Literals.suffix_js then false - else if str = Literals.suffix_bs_js then true - else Bsb_exception.config_error config "expect .bs.js or .js string here" - | Some config -> - Bsb_exception.config_error config "expect .bs.js or .js string here" - - let extract_gentype_config (map : json_map) cwd : Bsb_config_types.gentype_config option = match Map_string.find_opt map Bsb_build_schemas.gentypeconfig with @@ -11489,7 +11543,6 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : let package_name, namespace = extract_package_name_and_namespace map in let refmt = extract_refmt map per_proj_dir in let gentype_config = extract_gentype_config map per_proj_dir in - let bs_suffix = extract_bs_suffix_exn map in (* The default situation is empty *) let built_in_package = check_stdlib map per_proj_dir in let package_specs = @@ -11497,6 +11550,9 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : | Some x -> Bsb_package_specs.from_json x | None -> Bsb_package_specs.default_package_specs in + let bs_suffixes = + Bsb_package_specs.extract_in_source_bs_suffixes package_specs + in let pp_flags : string option = extract_string map Bsb_build_schemas.pp_flags (fun p -> if p = "" then @@ -11525,12 +11581,11 @@ let interpret_json ~toplevel_package_specs ~(per_proj_dir : string) : in let groups, number_of_dev_groups = Bsb_parse_sources.scan ~ignored_dirs:(extract_ignored_dirs map) - ~toplevel ~root:per_proj_dir ~cut_generators ~bs_suffix ~namespace - sources + ~toplevel ~root:per_proj_dir ~cut_generators ~bs_suffixes + ~namespace sources in { gentype_config; - bs_suffix; package_name; namespace; warning = extract_warning map; @@ -12517,7 +12572,6 @@ val make_custom_rules : has_ppx:bool -> has_pp:bool -> has_builtin:bool -> - bs_suffix:bool -> reason_react_jsx:Bsb_config_types.reason_react_jsx option -> digest:string -> refmt:string option -> @@ -12627,7 +12681,7 @@ type builtin = { } let make_custom_rules ~(has_gentype : bool) ~(has_postbuild : bool) - ~(has_ppx : bool) ~(has_pp : bool) ~(has_builtin : bool) ~(bs_suffix : bool) + ~(has_ppx : bool) ~(has_pp : bool) ~(has_builtin : bool) ~(reason_react_jsx : Bsb_config_types.reason_react_jsx option) ~(digest : string) ~(refmt : string option) (* set refmt path when needed *) @@ -12638,7 +12692,6 @@ let make_custom_rules ~(has_gentype : bool) ~(has_postbuild : bool) let mk_ml_cmj_cmd ~read_cmi ~is_dev ~postbuild : string = Buffer.clear buf; Buffer.add_string buf "$bsc -nostdlib $g_pkg_flg -color always"; - if bs_suffix then Buffer.add_string buf " -bs-suffix"; if read_cmi then Buffer.add_string buf " -bs-read-cmi"; if is_dev then Buffer.add_string buf " $g_dev_incls"; Buffer.add_string buf " $g_lib_incls"; @@ -12985,7 +13038,6 @@ module Bsb_ninja_file_groups : sig val handle_files_per_dir : out_channel -> - bs_suffix:bool -> rules:Bsb_ninja_rule.builtin -> package_specs:Bsb_package_specs.t -> js_post_build_cmd:string option -> @@ -13058,7 +13110,7 @@ let make_common_shadows package_specs dirname dir_index : let emit_module_build (rules : Bsb_ninja_rule.builtin) (package_specs : Bsb_package_specs.t) (group_dir_index : Bsb_dir_index.t) oc - ~bs_suffix js_post_build_cmd namespace (module_info : Bsb_db.module_info) = + js_post_build_cmd namespace (module_info : Bsb_db.module_info) = let has_intf_file = module_info.info = Ml_mli in let is_re = module_info.is_re in let filename_sans_extension = module_info.name_sans_extension in @@ -13088,7 +13140,7 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) let output_cmi = output_filename_sans_extension ^ Literals.suffix_cmi in let output_cmj = output_filename_sans_extension ^ Literals.suffix_cmj in let output_js = - Bsb_package_specs.get_list_of_output_js package_specs bs_suffix + Bsb_package_specs.get_list_of_output_js package_specs output_filename_sans_extension in let common_shadows = @@ -13153,8 +13205,8 @@ let emit_module_build (rules : Bsb_ninja_rule.builtin) ~order_only_deps:[ output_d ] ~rule -let handle_files_per_dir oc ~bs_suffix ~(rules : Bsb_ninja_rule.builtin) - ~package_specs ~js_post_build_cmd ~(files_to_install : Hash_set_string.t) +let handle_files_per_dir oc ~(rules : Bsb_ninja_rule.builtin) ~package_specs + ~js_post_build_cmd ~(files_to_install : Hash_set_string.t) ~(namespace : string option) (group : Bsb_file_groups.file_group) : unit = handle_generators oc group rules.customs; let installable = @@ -13166,8 +13218,8 @@ let handle_files_per_dir oc ~bs_suffix ~(rules : Bsb_ninja_rule.builtin) Map_string.iter group.sources (fun module_name module_info -> if installable module_name then Hash_set_string.add files_to_install module_info.name_sans_extension; - emit_module_build rules package_specs group.dir_index oc ~bs_suffix - js_post_build_cmd namespace module_info) + emit_module_build rules package_specs group.dir_index oc js_post_build_cmd + namespace module_info) (* pseuduo targets per directory *) @@ -13276,7 +13328,6 @@ let output_static_resources (static_resources : string list) copy_rule oc = let output_ninja_and_namespace_map ~per_proj_dir ~toplevel ({ - bs_suffix; package_name; external_includes; bsc_flags; @@ -13401,7 +13452,7 @@ let output_ninja_and_namespace_map ~per_proj_dir ~toplevel ~has_postbuild:(js_post_build_cmd <> None) ~has_ppx:(ppx_files <> []) ~has_pp:(pp_file <> None) ~has_builtin:(built_in_dependency <> None) - ~reason_react_jsx ~bs_suffix ~digest generators + ~reason_react_jsx ~digest generators in emit_bsc_lib_includes bs_dependencies bsc_lib_dirs external_includes namespace @@ -13409,9 +13460,8 @@ let output_ninja_and_namespace_map ~per_proj_dir ~toplevel output_static_resources static_resources rules.copy_resources oc; (* Generate build statement for each file *) Ext_list.iter bs_file_groups (fun files_per_dir -> - Bsb_ninja_file_groups.handle_files_per_dir oc ~bs_suffix ~rules - ~js_post_build_cmd ~package_specs ~files_to_install ~namespace - files_per_dir); + Bsb_ninja_file_groups.handle_files_per_dir oc ~rules ~js_post_build_cmd + ~package_specs ~files_to_install ~namespace files_per_dir); Ext_option.iter namespace (fun ns -> let namespace_dir = per_proj_dir // Bsb_config.lib_bs in diff --git a/lib/4.06.1/unstable/bspack.ml b/lib/4.06.1/unstable/bspack.ml index eadd60b9f3..ebee86f4cf 100644 --- a/lib/4.06.1/unstable/bspack.ml +++ b/lib/4.06.1/unstable/bspack.ml @@ -9966,7 +9966,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -10105,7 +10107,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 2d94e1783b..9a54c47773 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -14306,7 +14306,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14324,29 +14324,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit +val warn_literal_overflow : Location.t -> unit -val warn_literal_overflow : Location.t -> unit - -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14364,117 +14360,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end - + Format.pp_print_flush warning_formatter () ) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error -(** - Note the standard way of reporting error in compiler: + Provide a printer to error - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type - - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Ext_util : sig @@ -15178,7 +15155,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -15317,7 +15296,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -75486,7 +75467,10 @@ val make : ?ns:string -> string -> string val try_split_module_name : string -> (string * string) option -val change_ext_ns_suffix : string -> string -> string +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) type file_kind = Upper_js | Upper_bs | Little_js | Little_bs @@ -75556,7 +75540,7 @@ let rec rindex_rec s i = #1933 when removing ns suffix, don't pass the bound of basename FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = +let replace_namespace_with_extension ~name ~ext = let i = rindex_rec name (String.length name - 1) in if i < 0 then name ^ ext else String.sub name 0 i ^ ext @@ -75573,13 +75557,16 @@ type file_kind = Upper_js | Upper_bs | Little_js | Little_bs let js_name_of_modulename s little = match little with | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js (** https://docs.npmjs.com/files/package.json @@ -128729,10 +128716,11 @@ let ( // ) = Filename.concat let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : unit = let basename = - Ext_namespace.change_ext_ns_suffix - (Filename.basename output_prefix) - ( if !Js_config.bs_suffix then Literals.suffix_bs_js - else Literals.suffix_js ) + Ext_namespace.replace_namespace_with_extension + ~name:(Filename.basename output_prefix) + ~ext: + ( if !Js_config.bs_suffix then Literals.suffix_bs_js + else Literals.suffix_js ) in let package_info = Js_current_package_info.get_packages_info () in if Js_package_info.is_empty package_info && !Js_config.js_stdout then diff --git a/lib/4.06.1/unstable/js_refmt_compiler.ml b/lib/4.06.1/unstable/js_refmt_compiler.ml index d0b13f0dab..94c0fa0b95 100644 --- a/lib/4.06.1/unstable/js_refmt_compiler.ml +++ b/lib/4.06.1/unstable/js_refmt_compiler.ml @@ -14306,7 +14306,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14324,29 +14324,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit +val warn_literal_overflow : Location.t -> unit -val warn_literal_overflow : Location.t -> unit - -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14364,117 +14360,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end - + Format.pp_print_flush warning_formatter () ) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error -(** - Note the standard way of reporting error in compiler: + Provide a printer to error - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type - - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Ext_util : sig @@ -15178,7 +15155,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -15317,7 +15296,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -75486,7 +75467,10 @@ val make : ?ns:string -> string -> string val try_split_module_name : string -> (string * string) option -val change_ext_ns_suffix : string -> string -> string +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) type file_kind = Upper_js | Upper_bs | Little_js | Little_bs @@ -75556,7 +75540,7 @@ let rec rindex_rec s i = #1933 when removing ns suffix, don't pass the bound of basename FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = +let replace_namespace_with_extension ~name ~ext = let i = rindex_rec name (String.length name - 1) in if i < 0 then name ^ ext else String.sub name 0 i ^ ext @@ -75573,13 +75557,16 @@ type file_kind = Upper_js | Upper_bs | Little_js | Little_bs let js_name_of_modulename s little = match little with | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js (** https://docs.npmjs.com/files/package.json @@ -128729,10 +128716,11 @@ let ( // ) = Filename.concat let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : unit = let basename = - Ext_namespace.change_ext_ns_suffix - (Filename.basename output_prefix) - ( if !Js_config.bs_suffix then Literals.suffix_bs_js - else Literals.suffix_js ) + Ext_namespace.replace_namespace_with_extension + ~name:(Filename.basename output_prefix) + ~ext: + ( if !Js_config.bs_suffix then Literals.suffix_bs_js + else Literals.suffix_js ) in let package_info = Js_current_package_info.get_packages_info () in if Js_package_info.is_empty package_info && !Js_config.js_stdout then diff --git a/lib/4.06.1/unstable/native_ppx.ml b/lib/4.06.1/unstable/native_ppx.ml index 5fba0f550e..a21d68e3f7 100644 --- a/lib/4.06.1/unstable/native_ppx.ml +++ b/lib/4.06.1/unstable/native_ppx.ml @@ -14284,7 +14284,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14302,29 +14302,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit - -val warn_literal_overflow : Location.t -> unit +val warn_literal_overflow : Location.t -> unit -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -14342,117 +14338,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end + Format.pp_print_flush warning_formatter () ) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error + Provide a printer to error -(** - Note the standard way of reporting error in compiler: - - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type - - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Ext_util : sig @@ -15156,7 +15133,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -15295,7 +15274,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index dfff503a41..74a670e661 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -61286,7 +61286,9 @@ val suffix_rei : string val suffix_d : string val suffix_js : string +val suffix_mjs : string val suffix_bs_js : string +val suffix_bs_mjs : string (* val suffix_re_js : string *) val suffix_gen_js : string val suffix_gen_tsx: string @@ -61425,7 +61427,9 @@ let suffix_reiast = ".reiast" let suffix_mliast_simple = ".mliast_simple" let suffix_d = ".d" let suffix_js = ".js" +let suffix_mjs = ".mjs" let suffix_bs_js = ".bs.js" +let suffix_bs_mjs = ".bs.mjs" (* let suffix_re_js = ".re.js" *) let suffix_gen_js = ".gen.js" let suffix_gen_tsx = ".gen.tsx" @@ -61492,7 +61496,10 @@ val make : ?ns:string -> string -> string val try_split_module_name : string -> (string * string) option -val change_ext_ns_suffix : string -> string -> string +val replace_namespace_with_extension : name:string -> ext:string -> string +(** [replace_namespace_with_extension ~name ~ext] removes the part of [name] + after [ns_sep_char], if any; and appends [ext]. +*) type file_kind = Upper_js | Upper_bs | Little_js | Little_bs @@ -61562,7 +61569,7 @@ let rec rindex_rec s i = #1933 when removing ns suffix, don't pass the bound of basename FIXME: micro-optimizaiton *) -let change_ext_ns_suffix name ext = +let replace_namespace_with_extension ~name ~ext = let i = rindex_rec name (String.length name - 1) in if i < 0 then name ^ ext else String.sub name 0 i ^ ext @@ -61579,13 +61586,16 @@ type file_kind = Upper_js | Upper_bs | Little_js | Little_bs let js_name_of_modulename s little = match little with | Little_js -> - change_ext_ns_suffix (Ext_string.uncapitalize_ascii s) Literals.suffix_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_js | Little_bs -> - change_ext_ns_suffix - (Ext_string.uncapitalize_ascii s) - Literals.suffix_bs_js - | Upper_js -> change_ext_ns_suffix s Literals.suffix_js - | Upper_bs -> change_ext_ns_suffix s Literals.suffix_bs_js + replace_namespace_with_extension + ~name:(Ext_string.uncapitalize_ascii s) + ~ext:Literals.suffix_bs_js + | Upper_js -> replace_namespace_with_extension ~name:s ~ext:Literals.suffix_js + | Upper_bs -> + replace_namespace_with_extension ~name:s ~ext:Literals.suffix_bs_js (** https://docs.npmjs.com/files/package.json @@ -110830,7 +110840,7 @@ end module Bs_warnings : sig #1 "bs_warnings.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -110848,29 +110858,25 @@ module Bs_warnings : sig * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Unsafe_poly_variant_type +type t = Unsafe_poly_variant_type val prerr_bs_ffi_warning : Location.t -> t -> unit +val warn_missing_primitive : Location.t -> string -> unit -val warn_missing_primitive : Location.t -> string -> unit - -val warn_literal_overflow : Location.t -> unit +val warn_literal_overflow : Location.t -> unit -val error_unescaped_delimiter : - Location.t -> string -> unit +val error_unescaped_delimiter : Location.t -> string -> unit end = struct #1 "bs_warnings.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * + * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published by * the Free Software Foundation, either version 3 of the License, or @@ -110888,117 +110894,98 @@ end = struct * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. - * + * * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - type t = | Unsafe_poly_variant_type - (* for users write code like this: - {[ external f : [`a of int ] -> string = ""]} - Here users forget about `[@bs.string]` or `[@bs.int]` - *) + (** for users write code like this: + {[ external f : [ `a of int ] -> string = "" ]} + Here users forget about `[@bs.string]` or `[@bs.int]` *) let to_string t = match t with - | Unsafe_poly_variant_type - -> - "Here a OCaml polymorphic variant type passed into JS, probably you forgot annotations like `[@bs.int]` or `[@bs.string]` " + | Unsafe_poly_variant_type -> + "Here a OCaml polymorphic variant type passed into JS, probably you \ + forgot annotations like `[@bs.int]` or `[@bs.string]` " + let warning_formatter = Format.err_formatter -let print_string_warning (loc : Location.t) x = - if loc.loc_ghost then - Format.fprintf warning_formatter "File %s@." !Location.input_name - else - Location.print warning_formatter loc ; - Format.fprintf warning_formatter "@{Warning@}: %s@." x +let print_string_warning (loc : Location.t) x = + if loc.loc_ghost then + Format.fprintf warning_formatter "File %s@." !Location.input_name + else Location.print warning_formatter loc; + Format.fprintf warning_formatter "@{Warning@}: %s@." x -let prerr_bs_ffi_warning loc x = - Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let unimplemented_primitive = "Unimplemented primitive used:" -type error = - | Uninterpreted_delimiters of string - | Unimplemented_primitive of string -exception Error of Location.t * error +let prerr_bs_ffi_warning loc x = + Location.prerr_warning loc (Warnings.Bs_ffi_warning (to_string x)) -let pp_error fmt x = - match x with - | Unimplemented_primitive str -> - Format.pp_print_string fmt unimplemented_primitive; - Format.pp_print_string fmt str - - | Uninterpreted_delimiters str -> - Format.pp_print_string fmt "Uninterpreted delimiters" ; - Format.pp_print_string fmt str +let unimplemented_primitive = "Unimplemented primitive used:" +type error = + | Uninterpreted_delimiters of string + | Unimplemented_primitive of string +exception Error of Location.t * error +let pp_error fmt x = + match x with + | Unimplemented_primitive str -> + Format.pp_print_string fmt unimplemented_primitive; + Format.pp_print_string fmt str + | Uninterpreted_delimiters str -> + Format.pp_print_string fmt "Uninterpreted delimiters"; + Format.pp_print_string fmt str -let () = - Location.register_error_of_exn (function - | Error (loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) + | _ -> None) +let warn_missing_primitive loc txt = + if (not !Js_config.no_warn_unimplemented_external) && not !Clflags.bs_quiet + then ( + print_string_warning loc (unimplemented_primitive ^ txt ^ " \n"); + Format.pp_print_flush warning_formatter () ) -let warn_missing_primitive loc txt = - if not !Js_config.no_warn_unimplemented_external && not !Clflags.bs_quiet then - begin - print_string_warning loc ( unimplemented_primitive ^ txt ^ " \n" ); - Format.pp_print_flush warning_formatter () - end -let warn_literal_overflow loc = - if not !Clflags.bs_quiet then - begin - print_string_warning loc +let warn_literal_overflow loc = + if not !Clflags.bs_quiet then ( + print_string_warning loc "Integer literal exceeds the range of representable integers of type int"; - Format.pp_print_flush warning_formatter () - end - + Format.pp_print_flush warning_formatter () ) -let error_unescaped_delimiter loc txt = - raise (Error(loc, Uninterpreted_delimiters txt)) +let error_unescaped_delimiter loc txt = + raise (Error (loc, Uninterpreted_delimiters txt)) +(** Note the standard way of reporting error in compiler: + val Location.register_error_of_exn : (exn -> Location.error option) -> unit + val Location.error_of_printer : Location.t -> (Format.formatter -> error -> + unit) -> error -> Location.error + Define an error type + type error exception Error of Location.t * error -(** - Note the standard way of reporting error in compiler: + Provide a printer to error - val Location.register_error_of_exn : (exn -> Location.error option) -> unit - val Location.error_of_printer : Location.t -> - (Format.formatter -> error -> unit) -> error -> Location.error - - Define an error type - - type error - exception Error of Location.t * error - - Provide a printer to error - - {[ - let () = - Location.register_error_of_exn - (function - | Error(loc,err) -> - Some (Location.error_of_printer loc pp_error err) - | _ -> None - ) - ]} -*) + {[ + let () = + Location.register_error_of_exn (function + | Error (loc, err) -> + Some (Location.error_of_printer loc pp_error err) + | _ -> None) + ]} *) end module Js_of_lam_exception : sig @@ -406534,10 +406521,11 @@ let ( // ) = Filename.concat let lambda_as_module (lambda_output : J.deps_program) (output_prefix : string) : unit = let basename = - Ext_namespace.change_ext_ns_suffix - (Filename.basename output_prefix) - ( if !Js_config.bs_suffix then Literals.suffix_bs_js - else Literals.suffix_js ) + Ext_namespace.replace_namespace_with_extension + ~name:(Filename.basename output_prefix) + ~ext: + ( if !Js_config.bs_suffix then Literals.suffix_bs_js + else Literals.suffix_js ) in let package_info = Js_current_package_info.get_packages_info () in if Js_package_info.is_empty package_info && !Js_config.js_stdout then