From 8608d0b5a9a0ba2eeaf9f3e9cae61efd0f375414 Mon Sep 17 00:00:00 2001 From: Hongbo Zhang Date: Mon, 1 Aug 2016 16:32:23 -0400 Subject: [PATCH] snapshot --- jscomp/bin/compiler.ml | 4801 +++++++++++++++++++++------------------- 1 file changed, 2492 insertions(+), 2309 deletions(-) diff --git a/jscomp/bin/compiler.ml b/jscomp/bin/compiler.ml index 082a0d8510..03dd434560 100644 --- a/jscomp/bin/compiler.ml +++ b/jscomp/bin/compiler.ml @@ -1,6 +1,6 @@ -(** Bundled by ocaml_pack 07/27-13:21 *) -module Literals : sig -#1 "literals.mli" +(** Bundled by ocaml_pack 08/01-16:32 *) +module String_set : sig +#1 "string_set.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -30,51 +30,12 @@ module Literals : sig -val js_array_ctor : string -val js_type_number : string -val js_type_string : string -val js_type_object : string -val js_undefined : string -val js_prop_length : string - -val param : string -val partial_arg : string -val prim : string - -(**temporary varaible used in {!Js_ast_util} *) -val tmp : string - -val create : string - -val app : string -val app_array : string - -val runtime : string -val stdlib : string -val imul : string - -val setter_suffix : string -val setter_suffix_len : int - - -val js_debugger : string -val js_pure_expr : string -val js_pure_stmt : string -val js_unsafe_downgrade : string -val js_fn_run : string -val js_method_run : string -val js_fn_method : string -val js_fn_mk : string -(** callback actually, not exposed to user yet *) -val js_fn_runmethod : string -val bs_deriving : string -val bs_deriving_dot : string -val bs_type : string +include Set.S with type elt = string end = struct -#1 "literals.ml" +#1 "string_set.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -105,46 +66,8 @@ end = struct -let js_array_ctor = "Array" -let js_type_number = "number" -let js_type_string = "string" -let js_type_object = "object" -let js_undefined = "undefined" -let js_prop_length = "length" - -let prim = "prim" -let param = "param" -let partial_arg = "partial_arg" -let tmp = "tmp" - -let create = "create" (* {!Caml_exceptions.create}*) - -let app = "_" -let app_array = "app" (* arguments are an array*) - -let runtime = "runtime" (* runtime directory *) - -let stdlib = "stdlib" - -let imul = "imul" (* signed int32 mul *) - -let setter_suffix = "#=" -let setter_suffix_len = String.length setter_suffix - -let js_debugger = "js_debugger" -let js_pure_expr = "js_pure_expr" -let js_pure_stmt = "js_pure_stmt" -let js_unsafe_downgrade = "js_unsafe_downgrade" -let js_fn_run = "js_fn_run" -let js_method_run = "js_method_run" - -let js_fn_method = "js_fn_method" -let js_fn_mk = "js_fn_mk" -let js_fn_runmethod = "js_fn_runmethod" -let bs_deriving = "bs.deriving" -let bs_deriving_dot = "bs.deriving." -let bs_type = "bs.type" +include Set.Make(String) end module Ext_bytes : sig @@ -549,8 +472,8 @@ let starts_with_and_number s ~offset beg = -1 end -module String_map : sig -#1 "string_map.mli" +module Ext_pervasives : sig +#1 "ext_pervasives.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -582,12 +505,31 @@ module String_map : sig -include Map.S with type key = string +(** Extension to standard library [Pervavives] module, safe to open + *) + +external reraise: exn -> 'a = "%reraise" +val finally : 'a -> ('a -> 'b) -> ('a -> 'c) -> 'b + +val with_file_as_chan : string -> (out_channel -> 'a) -> 'a + +val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a + +val is_pos_pow : Int32.t -> int + +val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a + +val invalid_argf : ('a, unit, string, 'b) format4 -> 'a + +val bad_argf : ('a, unit, string, 'b) format4 -> 'a + + + +val dump : 'a -> string -val of_list : (key * 'a) list -> 'a t end = struct -#1 "string_map.ml" +#1 "ext_pervasives.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -617,16 +559,133 @@ end = struct +external reraise: exn -> 'a = "%reraise" +let finally v f action = + match f v with + | exception e -> + action v ; + reraise e + | e -> action v ; e -include Map.Make(String) +let with_file_as_chan filename f = + let chan = open_out filename in + finally chan f close_out + +let with_file_as_pp filename f = + let chan = open_out filename in + finally chan + (fun chan -> + let fmt = Format.formatter_of_out_channel chan in + let v = f fmt in + Format.pp_print_flush fmt (); + v + ) close_out + + +let is_pos_pow n = + let module M = struct exception E end in + let rec aux c (n : Int32.t) = + if n <= 0l then -2 + else if n = 1l then c + else if Int32.logand n 1l = 0l then + aux (c + 1) (Int32.shift_right n 1 ) + else raise M.E in + try aux 0 n with M.E -> -1 + +let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s)) + fmt + +let invalid_argf fmt = Format.ksprintf invalid_arg fmt + +let bad_argf fmt = Format.ksprintf (fun x -> raise (Arg.Bad x ) ) fmt + + +let rec dump r = + if Obj.is_int r then + string_of_int (Obj.magic r : int) + else (* Block. *) + let rec get_fields acc = function + | 0 -> acc + | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n + in + let rec is_list r = + if Obj.is_int r then + r = Obj.repr 0 (* [] *) + else + let s = Obj.size r and t = Obj.tag r in + t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) + in + let rec get_list r = + if Obj.is_int r then + [] + else + let h = Obj.field r 0 and t = get_list (Obj.field r 1) in + h :: t + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible + * in pure OCaml at the moment. *) + "<" ^ name ^ ">" + in + let s = Obj.size r and t = Obj.tag r in + (* From the tag, determine the type of block. *) + match t with + | _ when is_list r -> + let fields = get_list r in + "[" ^ String.concat "; " (List.map dump fields) ^ "]" + | 0 -> + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map dump fields) ^ ")" + | x when x = Obj.lazy_tag -> + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + opaque "lazy" + | x when x = Obj.closure_tag -> + opaque "closure" + | x when x = Obj.object_tag -> + let fields = get_fields [] s in + let _clasz, id, slots = + match fields with + | h::h'::t -> h, h', t + | _ -> assert false + in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. *) + "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")" + | x when x = Obj.infix_tag -> + opaque "infix" + | x when x = Obj.forward_tag -> + opaque "forward" + | x when x < Obj.no_scan_tag -> + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map dump fields) ^ ")" + | x when x = Obj.string_tag -> + "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" + | x when x = Obj.double_tag -> + string_of_float (Obj.magic r : float) + | x when x = Obj.abstract_tag -> + opaque "abstract" + | x when x = Obj.custom_tag -> + opaque "custom" + | x when x = Obj.custom_tag -> + opaque "final" + | x when x = Obj.double_array_tag -> + "[|"^ + String.concat ";" + (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^ + "|]" + | _ -> + opaque (Printf.sprintf "unknown: tag %d size %d" t s) + +let dump v = dump (Obj.repr v) -let of_list (xs : ('a * 'b) list ) = - List.fold_left (fun acc (k,v) -> add k v acc) empty xs end -module Ast_payload : sig -#1 "ast_payload.mli" +module Ext_sys : sig +#1 "ext_sys.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -651,44 +710,10 @@ module Ast_payload : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -(** A utility module used when destructuring parsetree attributes, used for - compiling FFI attributes and built-in ppx *) - -type t = Parsetree.payload -type lid = Longident.t Asttypes.loc -type label_expr = lid * Parsetree.expression -type action = - lid * Parsetree.expression option - -val is_single_string : t -> string option -val is_single_int : t -> int option - -val as_string_exp : t -> Parsetree.expression option -val as_empty_structure : t -> bool -val is_string_or_strings : - t -> [ `None | `Single of string | `Some of string list ] - -(** as a record or empty - it will accept - {[ [@@@bs.config ]]} - or - {[ [@@@bs.config { property .. } ]]} -*) -val as_record_and_process : - Location.t -> - t -> action list - -val assert_bool_lit : Parsetree.expression -> bool - -val empty : t - -val table_dispatch : - (Parsetree.expression option -> 'a) String_map.t -> action -> 'a +val is_directory_no_exn : string -> bool end = struct -#1 "ast_payload.ml" +#1 "ext_sys.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -713,143 +738,13 @@ 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. *) -type t = Parsetree.payload - -let is_single_string (x : t ) = - match x with (** TODO also need detect empty phrase case *) - | PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_string (name,_)); - _},_); - _}] -> Some name - | _ -> None - -let is_single_int (x : t ) = - match x with (** TODO also need detect empty phrase case *) - | PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_int name); - _},_); - _}] -> Some name - | _ -> None - -let as_string_exp (x : t ) = - match x with (** TODO also need detect empty phrase case *) - | PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_string (_,_)); - _} as e ,_); - _}] -> Some e - | _ -> None - -let as_empty_structure (x : t ) = - match x with - | PStr ([]) -> true - | PTyp _ | PPat _ | PStr (_ :: _ ) -> false - -type lid = Longident.t Asttypes.loc -type label_expr = lid * Parsetree.expression -type action = - lid * Parsetree.expression option - - -let as_record_and_process - loc - x - = - match x with - | Parsetree.PStr - [ {pstr_desc = Pstr_eval - ({pexp_desc = Pexp_record (label_exprs, with_obj) ; pexp_loc = loc}, _); - _ - }] - -> - begin match with_obj with - | None -> - List.map - (fun (x,y) -> - match (x,y) with - | ({Asttypes.txt = Longident.Lident name; loc} ) , - ({Parsetree.pexp_desc = Pexp_ident{txt = Lident name2}} ) - when name2 = name -> - (x, None) - | _ -> (x, Some y)) - label_exprs - | Some _ -> - Location.raise_errorf ~loc "with is not supported" - end - | Parsetree.PStr [] -> [] - | _ -> - Location.raise_errorf ~loc "this is not a valid record config" - -let is_string_or_strings (x : t) : - [ `None | `Single of string | `Some of string list ] = - let module M = struct exception Not_str end in - match x with - | PStr [ {pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_apply - ({pexp_desc = Pexp_constant (Const_string (name,_)); _}, - args - ); - _},_); - _}] -> - (try - `Some (name :: (args |> List.map (fun (_label,e) -> - match (e : Parsetree.expression) with - | {pexp_desc = Pexp_constant (Const_string (name,_)); _} -> - name - | _ -> raise M.Not_str))) - - with M.Not_str -> `None ) - | PStr [ { - pstr_desc = - Pstr_eval ( - {pexp_desc = - Pexp_constant - (Const_string (name,_)); - _},_); - _}] -> `Single name - | _ -> `None - -let assert_bool_lit (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_construct ({txt = Lident "true" }, None) - -> true - | Pexp_construct ({txt = Lident "false" }, None) - -> false - | _ -> - Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field" - - -let empty : t = Parsetree.PStr [] - - -let table_dispatch table (action : action) - = - match action with - | {txt = Lident name; loc }, y -> - begin match String_map.find name table with - | fn -> fn y - | exception _ -> Location.raise_errorf ~loc "%s is not supported" name - end - | { loc ; }, _ -> - Location.raise_errorf ~loc "invalid label for config" +let is_directory_no_exn f = + try Sys.is_directory f with _ -> false end -module Ast_attributes : sig -#1 "ast_attributes.mli" +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 @@ -873,51 +768,51 @@ module Ast_attributes : sig * 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 attr = Parsetree.attribute -type t = attr list -type ('a,'b) st = - { get : 'a option ; - set : 'b option } -val process_method_attributes_rev : - t -> - (bool * bool , [`Get | `No_get ]) st * t -val process_attributes_rev : - t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t -val process_class_type_decl_rev : - t -> [ `Nothing | `Has] * t -val process_external : t -> bool -val process_bs_type : t -> Parsetree.core_type option * t -type derive_attr = { - explict_nonrec : bool; - bs_deriving : [`Has_deriving of Ast_payload.action list | `Nothing ] -} -val process_bs_string_int : - t -> [`Nothing | `String | `Int] +(* TODO: + Change the module name, this code is not really an extension of the standard + library but rather specific to JS Module name convention. +*) -val process_bs_string_as : - t -> string option -val process_bs_int_as : - t -> int option +type t = + [ `File of string + | `Dir of string ] +val combine : string -> string -> string +val path_as_directory : string -> string -val process_derive_type : - t -> derive_attr * t +(** An extension module to calculate relative path follow node/npm style. + TODO : this short name will have to change upon renaming the file. + *) +(** Js_output is node style, which means + separator is only '/' -val bs_obj : Parsetree.core_type -> t -val bs : attr -val bs_this : attr -val bs_method : attr + if the path contains 'node_modules', + [node_relative_path] will discard its prefix and + just treat it as a library instead + *) -val mk_bs_type : ?loc:Location.t -> Parsetree.core_type -> attr +val node_relative_path : t -> [`File of string] -> string + +val chop_extension : ?loc:string -> string -> string + + +val resolve_bs_package : cwd:string -> string -> string + + + +val cwd : string Lazy.t +val package_dir : string Lazy.t + +val replace_backward_slash : string -> string end = struct -#1 "ast_attributes.ml" +#1 "ext_filename.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -942,261 +837,226 @@ 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. *) -type attr = Parsetree.attribute -type t = attr list -type ('a,'b) st = - { get : 'a option ; - set : 'b option } -let process_method_attributes_rev (attrs : t) = - List.fold_left (fun (st,acc) (({txt ; loc}, payload) as attr : attr) -> - match txt with - | "bs.get" (* [@@bs.get{null; undefined}]*) - -> - let result = - List.fold_left - (fun - (null, undefined) - (({txt ; loc}, opt_expr) : Ast_payload.action) -> - if txt = Lident "null" then - (match opt_expr with - | None -> true - | Some e -> - Ast_payload.assert_bool_lit e), undefined - else if txt = Lident "undefined" then - null, - (match opt_expr with - | None -> true - | Some e -> - Ast_payload.assert_bool_lit e) - else Location.raise_errorf ~loc "unsupported predicates" - ) (false, false) (Ast_payload.as_record_and_process loc payload) in - ({st with get = Some result}, acc ) - - | "bs.set" - -> - let result = - List.fold_left - (fun st (({txt ; loc}, opt_expr) : Ast_payload.action) -> - if txt = Lident "no_get" then - match opt_expr with - | None -> `No_get - | Some e -> - if Ast_payload.assert_bool_lit e then - `No_get - else `Get - else Location.raise_errorf ~loc "unsupported predicates" - ) `Get (Ast_payload.as_record_and_process loc payload) in - (* properties -- void - [@@bs.set{only}] - *) - {st with set = Some result }, acc - | _ -> - (st, attr::acc ) - ) ( {get = None ; set = None}, []) attrs +(** Used when produce node compatible paths *) +let node_sep = "/" +let node_parent = ".." +let node_current = "." +type t = + [ `File of string + | `Dir of string ] -let process_attributes_rev (attrs : t) = - List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> - match txt, st with - | "bs", (`Nothing | `Uncurry) - -> - `Uncurry, acc - | "bs.this", (`Nothing | `Meth_callback) - -> `Meth_callback, acc - | "bs.meth", (`Nothing | `Method) - -> `Method, acc - | "bs", _ - | "bs.this", _ - -> Location.raise_errorf - ~loc - "[@bs.this], [@bs], [@bs.meth] can not be applied at the same time" - | _ , _ -> - st, attr::acc - ) ( `Nothing, []) attrs +let cwd = lazy (Sys.getcwd ()) -let process_class_type_decl_rev attrs = - List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> - match txt, st with - | "bs", _ - -> - `Has, acc - | _ , _ -> - st, attr::acc - ) ( `Nothing, []) attrs +let (//) = Filename.concat -let process_external attrs = - List.exists (fun (({txt; }, _) : attr) -> - if Ext_string.starts_with txt "bs." then true - else false - ) attrs +let combine path1 path2 = + if path1 = "" then + path2 + else if path2 = "" then path1 + else + if Filename.is_relative path2 then + path1// path2 + else + path2 -let process_bs_type attrs = - List.fold_right (fun (attr : attr) (st, acc) -> - match attr with - | {txt = "bs.type" }, PTyp typ - -> - Some typ, acc - | _ -> - st, attr::acc - ) attrs (None, []) +(* Note that [.//] is the same as [./] *) +let path_as_directory x = + if x = "" then x + else + if Ext_string.ends_with x Filename.dir_sep then + x + else + x ^ Filename.dir_sep +let absolute_path s = + let process s = + let s = + if Filename.is_relative s then + Lazy.force cwd // s + else s in + (* Now simplify . and .. components *) + let rec aux s = + let base,dir = Filename.basename s, Filename.dirname s in + if dir = s then dir + else if base = Filename.current_dir_name then aux dir + else if base = Filename.parent_dir_name then Filename.dirname (aux dir) + else aux dir // base + in aux s in + match s with + | `File x -> `File (process x ) + | `Dir x -> `Dir (process x) -type derive_attr = { - explict_nonrec : bool; - bs_deriving : [`Has_deriving of Ast_payload.action list | `Nothing ] -} -let process_derive_type attrs = - List.fold_left - (fun (st, acc) - (({txt ; loc}, payload as attr): attr) -> - match st, txt with - | {bs_deriving = `Nothing}, "bs.deriving" - -> - {st with - bs_deriving = `Has_deriving - (Ast_payload.as_record_and_process loc payload)}, acc - | {bs_deriving = `Has_deriving _}, "bs.deriving" - -> - Location.raise_errorf ~loc "duplicated bs.deriving attribute" - | _ , _ -> - let st = - if txt = "nonrec" then - { st with explict_nonrec = true } - else st in - st, attr::acc - ) ( {explict_nonrec = false; bs_deriving = `Nothing }, []) attrs +let chop_extension ?(loc="") name = + try Filename.chop_extension name + with Invalid_argument _ -> + Ext_pervasives.invalid_argf + "Filename.chop_extension ( %s : %s )" loc name +let try_chop_extension s = try Filename.chop_extension s with _ -> s +(** example + {[ + "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj" + "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml" + ]} -let process_bs_string_int attrs = - List.fold_left - (fun st - (({txt ; loc}, payload ): attr) -> - match txt, st with - | "bs.string", (`Nothing | `String) - -> `String - | "bs.int", (`Nothing | `Int) - -> `Int - | "bs.int", _ - | "bs.string", _ - -> - Location.raise_errorf ~loc "conflict attributes " - | _ , _ -> st - ) `Nothing attrs + The other way + {[ + + "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml" + "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj" + ]} + {[ + "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib//ocaml_array.ml" + ]} + {[ + /a/b + /c/d + ]} + *) +let relative_path file_or_dir_1 file_or_dir_2 = + let sep_char = Filename.dir_sep.[0] in + let relevant_dir1 = + (match file_or_dir_1 with + | `Dir x -> x + | `File file1 -> Filename.dirname file1) in + let relevant_dir2 = + (match file_or_dir_2 with + |`Dir x -> x + |`File file2 -> Filename.dirname file2 ) in + let dir1 = Ext_string.split relevant_dir1 sep_char in + let dir2 = Ext_string.split relevant_dir2 sep_char in + let rec go (dir1 : string list) (dir2 : string list) = + match dir1, dir2 with + | x::xs , y :: ys when x = y + -> go xs ys + | _, _ + -> + List.map (fun _ -> node_parent) dir2 @ dir1 + in + match go dir1 dir2 with + | (x :: _ ) as ys when x = node_parent -> + String.concat node_sep ys + | ys -> + String.concat node_sep @@ node_current :: ys -let process_bs_string_as attrs = - List.fold_left - (fun st - (({txt ; loc}, payload ): attr) -> - match txt, st with - | "bs.as", None - -> - begin match Ast_payload.is_single_string payload with - | None -> - Location.raise_errorf ~loc "expect string literal " - | Some _ as v-> v - end - | "bs.as", _ - -> - Location.raise_errorf ~loc "duplicated bs.as " - | _ , _ -> st - ) None attrs -let process_bs_int_as attrs = - List.fold_left - (fun st - (({txt ; loc}, payload ): attr) -> - match txt, st with - | "bs.as", None - -> - begin match Ast_payload.is_single_int payload with - | None -> - Location.raise_errorf ~loc "expect int literal " - | Some _ as v-> v - end - | "bs.as", _ - -> - Location.raise_errorf ~loc "duplicated bs.as " - | _ , _ -> st - ) None attrs +let node_modules = "node_modules" +let node_modules_length = String.length "node_modules" +let package_json = "package.json" -let bs : attr - = {txt = "bs" ; loc = Location.none}, Ast_payload.empty -let bs_this : attr - = {txt = "bs.this" ; loc = Location.none}, Ast_payload.empty -let bs_method : attr - = {txt = "bs.meth"; loc = Location.none}, Ast_payload.empty -let mk_bs_type ?(loc=Location.none) ty : attr = - { txt = Literals.bs_type; loc }, PTyp ty -let bs_obj pval_type : t - = - [{txt = "bs.obj" ; loc = Location.none}, Ast_payload.empty ; - mk_bs_type pval_type - ] +(** path2: a/b + path1: a + result: ./b + TODO: [Filename.concat] with care -end -module Ast_core_type : sig -#1 "ast_core_type.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. *) + [file1] is currently compilation file + [file2] is the dependency + *) +let node_relative_path (file1 : t) + (`File file2 as dep_file : [`File of string]) = + let v = Ext_string.find file2 ~sub:node_modules in + let len = String.length file2 in + if v >= 0 then + let rec skip i = + if i >= len then + Ext_pervasives.failwithf ~loc:__LOC__ "invalid path: %s" file2 + else + match file2.[i] with + | '/' + | '.' -> skip (i + 1) + | _ -> i + (* + TODO: we need do more than this suppose user + input can be + {[ + "xxxghsoghos/ghsoghso/node_modules/../buckle-stdlib/list.js" + ]} + This seems weird though + *) + in + Ext_string.tail_from file2 + (skip (v + node_modules_length)) + else + relative_path + (absolute_path dep_file) + (absolute_path file1) + ^ node_sep ^ + try_chop_extension (Filename.basename file2) -type t = Parsetree.core_type -val list_of_arrow : t -> t * (string * t ) list -val replace_result : t -> t -> t +(** [resolve cwd module_name], + [cwd] is current working directory, absolute path + Trying to find paths to load [module_name] + it is sepcialized for option [-bs-package-include] which requires + [npm_package_name/lib/ocaml] +*) +let resolve_bs_package ~cwd name = + let sub_path = name // "lib" // "ocaml" in + let rec aux origin cwd name = + let destdir = cwd // node_modules // sub_path in + if Ext_sys.is_directory_no_exn destdir then destdir + else + let cwd' = Filename.dirname cwd in + if String.length cwd' < String.length cwd then + aux origin cwd' name + else + try + let destdir = + Sys.getenv "npm_config_prefix" + // "lib" // node_modules // sub_path in + if Ext_sys.is_directory_no_exn destdir + then destdir + else + Ext_pervasives.failwithf + ~loc:__LOC__ " %s not found in %s" name origin -val is_unit : t -> bool -val is_array : t -> bool + with + Not_found -> + Ext_pervasives.failwithf + ~loc:__LOC__ " %s not found in %s" name origin + in + aux cwd cwd name -(** for - [x:t] -> "x" - [?x:t] -> "?x" -*) -val label_name : string -> [ `Label of string | `Optional of string | `Empty] +let find_package_json_dir cwd = + let rec aux cwd = + if Sys.file_exists (cwd // package_json) then cwd + else + let cwd' = Filename.dirname cwd in + if String.length cwd' < String.length cwd then + aux cwd' + else + Ext_pervasives.failwithf + ~loc:__LOC__ + "package.json not found from %s" cwd + in + aux cwd -val string_type : t -> - [ `Int of (int * int) list | - `NonNullString of (int * string) list | - `NullString of (int * string) list | - `Nothing ] +let package_dir = lazy (find_package_json_dir (Lazy.force cwd)) -end = struct -#1 "ast_core_type.ml" +let replace_backward_slash (x : string)= + String.map (function + |'\\'-> '/' + | x -> x) x + +end +module Js_config : sig +#1 "js_config.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -1221,336 +1081,150 @@ 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. *) -type t = Parsetree.core_type -(** TODO check the polymorphic *) -let list_of_arrow (ty : t) = - let rec aux (ty : Parsetree.core_type) acc = - match ty.ptyp_desc with - | Ptyp_arrow(label,t1,t2) -> - aux t2 ((label,t1) ::acc) - | Ptyp_poly(_, ty) -> (* should not happen? *) - aux ty acc - | return_type -> ty, List.rev acc - in aux ty [] +type module_system = + [ `NodeJS | `AmdJS | `Goog ] (* This will be serliazed *) -let replace_result ty result = - let rec aux (ty : Parsetree.core_type) = - match ty with - | { ptyp_desc = - Ptyp_arrow (label,t1,t2) - } -> { ty with ptyp_desc = Ptyp_arrow(label,t1, aux t2)} - | {ptyp_desc = Ptyp_poly(fs,ty)} - -> {ty with ptyp_desc = Ptyp_poly(fs, aux ty)} - | _ -> result in - aux ty -let is_unit (ty : t ) = - match ty.ptyp_desc with - | Ptyp_constr({txt =Lident "unit"}, []) -> true - | _ -> false +type package_info = + (module_system * string ) -let is_array (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr({txt =Lident "array"}, [_]) -> true - | _ -> false +type package_name = string +type packages_info = + | Empty + | Browser + | NonBrowser of (package_name * package_info list) -let is_optional l = - String.length l > 0 && l.[0] = '?' -let label_name l = - if l = "" then `Empty else - if is_optional l - then `Optional (String.sub l 1 (String.length l - 1)) - else `Label l -let string_type (ty : t) = - match ty with - | {ptyp_desc; ptyp_attributes; ptyp_loc = loc} -> - match Ast_attributes.process_bs_string_int ptyp_attributes with - | `String -> - begin match ptyp_desc with - | Ptyp_variant ( row_fields, Closed, None) - -> - let case, result = - (List.fold_right (fun tag (nullary, acc) -> - match nullary, tag with - | (`Nothing | `Null), Parsetree.Rtag (label, attrs, true, []) - -> - let name = - match Ast_attributes.process_bs_string_as attrs with - | Some name -> name - | None -> label in - `Null, ((Btype.hash_variant label, name) :: acc ) - | (`Nothing | `NonNull), Parsetree.Rtag(label, attrs, false, [ _ ]) - -> - let name = - match Ast_attributes.process_bs_string_as attrs with - | Some name -> name - | None -> label in - `NonNull, ((Btype.hash_variant label, name) :: acc) +val cmj_ext : string - | _ -> Location.raise_errorf ~loc "Not a valid string type" - ) row_fields (`Nothing, [])) in - begin match case with - | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" - | `Null -> `NullString result - | `NonNull -> `NonNullString result - end - | _ -> Location.raise_errorf ~loc "Not a valid string type" - end - | `Int -> - begin match ptyp_desc with - | Ptyp_variant ( row_fields, Closed, None) - -> - let _, acc = - (List.fold_left - (fun (i,acc) rtag -> - match rtag with - | Parsetree.Rtag (label, attrs, true, []) - -> - let name = - match Ast_attributes.process_bs_int_as attrs with - | Some name -> name - | None -> i in - name + 1, ((Btype.hash_variant label , name):: acc ) - | _ -> Location.raise_errorf ~loc "Not a valid string type" - ) (0, []) row_fields) in - `Int (List.rev acc) - - | _ -> Location.raise_errorf ~loc "Not a valid string type" - end - | `Nothing -> `Nothing - +val is_browser : unit -> bool +val set_browser : unit -> unit -end -module Ext_ref : sig -#1 "ext_ref.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. *) -(** [non_exn_protect ref value f] assusme [f()] - would not raise -*) +val get_ext : unit -> string -val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b -val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b +(** depends on [package_infos], used in {!Js_program_loader} *) +val get_output_dir : module_system -> string -> string -val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c -(** [non_exn_protect2 refa refb va vb f ] - assume [f ()] would not raise -*) -val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c +(** used by command line option *) +val set_npm_package_path : string -> unit +val get_packages_info : unit -> packages_info -end = struct -#1 "ext_ref.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 non_exn_protect r v body = - let old = !r in - r := v; - let res = body() in - r := old; - res - -let protect r v body = - let old = !r in - try - r := v; - let res = body() in - r := old; - res - with x -> - r := old; - raise x - -let non_exn_protect2 r1 r2 v1 v2 body = - let old1 = !r1 in - let old2 = !r2 in - r1 := v1; - r2 := v2; - let res = body() in - r1 := old1; - r2 := old2; - res - -let protect2 r1 r2 v1 v2 body = - let old1 = !r1 in - let old2 = !r2 in - try - r1 := v1; - r2 := v2; - let res = body() in - r1 := old1; - r2 := old2; - res - with x -> - r1 := old1; - r2 := old2; - raise x - -end -module Ext_list : sig -#1 "ext_list.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. *) - - - - - - - - -(** Extension to the standard library [List] module *) - -(** TODO some function are no efficiently implemented. *) - -val filter_map : ('a -> 'b option) -> 'a list -> 'b list - -val excludes : ('a -> bool) -> 'a list -> bool * 'a list -val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list -val exclude_with_fact2 : - ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list -val same_length : 'a list -> 'b list -> bool +type info_query = + [ `Empty + | `Package_script of string + | `Found of package_name * string + | `NotFound + ] -val init : int -> (int -> 'a) -> 'a list +val query_package_infos : + packages_info -> + module_system -> + info_query -val take : int -> 'a list -> 'a list * 'a list -val try_take : int -> 'a list -> 'a list * int * 'a list -val exclude_tail : 'a list -> 'a list -val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list +(** set/get header *) +val no_version_header : bool ref -val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list -val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list +(** return [package_name] and [path] + when in script mode: +*) -val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list +val get_current_package_name_and_path : + module_system -> info_query -val flat_map : ('a -> 'b list) -> 'a list -> 'b list -val flat_map2_last : (bool -> 'a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list +val set_package_name : string -> unit +val get_package_name : unit -> string option -val map_last : (bool -> 'a -> 'b) -> 'a list -> 'b list +(** corss module inline option *) +val cross_module_inline : bool ref +val set_cross_module_inline : bool -> unit +val get_cross_module_inline : unit -> bool + +(** diagnose option *) +val diagnose : bool ref +val get_diagnose : unit -> bool +val set_diagnose : bool -> unit -val stable_group : ('a -> 'a -> bool) -> 'a list -> 'a list list -val drop : int -> 'a list -> 'a list +(** generate tds option *) +val default_gen_tds : bool ref -val for_all_ret : ('a -> bool) -> 'a list -> 'a option +(** options for builtion ppx *) +val no_builtin_ppx_ml : bool ref +val no_builtin_ppx_mli : bool ref -val for_all_opt : ('a -> 'b option) -> 'a list -> 'b option -(** [for_all_opt f l] returns [None] if all return [None], - otherwise returns the first one. - *) +(** check-div-by-zero option *) +val check_div_by_zero : bool ref +val get_check_div_by_zero : unit -> bool -val fold : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b -(** same as [List.fold_left]. - Provide an api so that list can be easily swapped by other containers +(* It will imply [-noassert] be set too, note from the implmentation point of view, + in the lambda layer, it is impossible to tell whehther it is [assert (3 <> 2)] or + [if (3<>2) then assert false] *) - -val rev_map_append : ('a -> 'b) -> 'a list -> 'b list -> 'b list - -val rev_map_acc : 'a list -> ('b -> 'a) -> 'b list -> 'a list - -val rev_iter : ('a -> unit) -> 'a list -> unit - -val for_all2_no_exn : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - -val find_opt : ('a -> 'b option) -> 'a list -> 'b option - -(** [f] is applied follow the list order *) -val split_map : ('a -> 'b * 'c) -> 'a list -> 'b list * 'c list +val no_any_assert : bool ref +val set_no_any_assert : unit -> unit +val get_no_any_assert : unit -> bool -val reduce_from_right : ('a -> 'a -> 'a) -> 'a list -> 'a -(** [fn] is applied from left to right *) -val reduce_from_left : ('a -> 'a -> 'a) -> 'a list -> 'a +(** Internal use *) +val runtime_set : String_set.t +val stdlib_set : String_set.t +(** only used in {!Js_generate_require} *) -type 'a t = 'a list ref +val block : string +val int32 : string +val gc : string +val backtrace : string +val version : string +val builtin_exceptions : string +val exceptions : string +val io : string +val oo : string +val sys : string +val lexer : string +val parser : string +val obj_runtime : string +val array : string +val format : string +val string : string +val float : string +val curry : string +(* val bigarray : string *) +(* val unix : string *) +val int64 : string +val md5 : string +val hash : string +val weak : string +val js_primitive : string +val module_ : string -val create_ref_empty : unit -> 'a t +(** Debugging utilies *) +val set_current_file : string -> unit +val get_current_file : unit -> string +val get_module_name : unit -> string -val ref_top : 'a t -> 'a +val iset_debug_file : string -> unit +val set_debug_file : string -> unit +val get_debug_file : unit -> string -val ref_empty : 'a t -> bool +val is_same_file : unit -> bool -val ref_push : 'a -> 'a t -> unit +val tool_name : string -val ref_pop : 'a t -> 'a +val is_windows : bool end = struct -#1 "ext_list.ml" +#1 "js_config.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -1581,314 +1255,293 @@ end = struct +type env = + | Browser + (* "browser-internal" used internal *) + | NodeJS + | AmdJS + | Goog (* of string option *) -let rec filter_map (f: 'a -> 'b option) xs = - match xs with - | [] -> [] - | y :: ys -> - begin match f y with - | None -> filter_map f ys - | Some z -> z :: filter_map f ys - end -let excludes p l = - let excluded = ref false in - let rec aux accu = function - | [] -> List.rev accu - | x :: l -> - if p x then - begin - excluded := true ; - aux accu l - end - else aux (x :: accu) l in - let v = aux [] l in - if !excluded then true, v else false,l - -let exclude_with_fact p l = - let excluded = ref None in - let rec aux accu = function - | [] -> List.rev accu - | x :: l -> - if p x then - begin - excluded := Some x ; - aux accu l - end - else aux (x :: accu) l in - let v = aux [] l in - !excluded , if !excluded <> None then v else l +type path = string +type module_system = + [ `NodeJS | `AmdJS | `Goog ] +type package_info = + ( module_system * string ) -(** Make sure [p2 x] and [p1 x] will not hold at the same time *) -let exclude_with_fact2 p1 p2 l = - let excluded1 = ref None in - let excluded2 = ref None in - let rec aux accu = function - | [] -> List.rev accu - | x :: l -> - if p1 x then - begin - excluded1 := Some x ; - aux accu l - end - else if p2 x then - begin - excluded2 := Some x ; - aux accu l - end - else aux (x :: accu) l in - let v = aux [] l in - !excluded1, !excluded2 , if !excluded1 <> None && !excluded2 <> None then v else l +type package_name = string +type packages_info = + | Empty (* No set *) + | Browser + | NonBrowser of (package_name * package_info list) +(** we don't force people to use package *) -let rec same_length xs ys = - match xs, ys with - | [], [] -> true - | _::xs, _::ys -> same_length xs ys - | _, _ -> false +let ext = ref ".js" +let cmj_ext = ".cmj" -let filter_mapi (f: int -> 'a -> 'b option) xs = - let rec aux i xs = - match xs with - | [] -> [] - | y :: ys -> - begin match f i y with - | None -> aux (i + 1) ys - | Some z -> z :: aux (i + 1) ys - end in - aux 0 xs -let rec filter_map2 (f: 'a -> 'b -> 'c option) xs ys = - match xs,ys with - | [],[] -> [] - | u::us, v :: vs -> - begin match f u v with - | None -> filter_map2 f us vs (* idea: rec f us vs instead? *) - | Some z -> z :: filter_map2 f us vs - end - | _ -> invalid_arg "Ext_list.filter_map2" -let filter_map2i (f: int -> 'a -> 'b -> 'c option) xs ys = - let rec aux i xs ys = - match xs,ys with - | [],[] -> [] - | u::us, v :: vs -> - begin match f i u v with - | None -> aux (i + 1) us vs (* idea: rec f us vs instead? *) - | Some z -> z :: aux (i + 1) us vs - end - | _ -> invalid_arg "Ext_list.filter_map2i" in - aux 0 xs ys +let get_ext () = !ext -let rec rev_map_append f l1 l2 = - match l1 with - | [] -> l2 - | a :: l -> rev_map_append f l (f a :: l2) -let flat_map2 f lx ly = - let rec aux acc lx ly = - match lx, ly with - | [], [] - -> List.rev acc - | x::xs, y::ys - -> aux (List.rev_append (f x y) acc) xs ys - | _, _ -> invalid_arg "Ext_list.flat_map2" in - aux [] lx ly - -let flat_map f lx = - let rec aux acc lx = - match lx with - | [] -> List.rev acc - | y::ys -> aux (List.rev_append ( f y) acc ) ys in - aux [] lx +let packages_info : packages_info ref = ref Empty -let rec map2_last f l1 l2 = - match (l1, l2) with - | ([], []) -> [] - | [u], [v] -> [f true u v ] - | (a1::l1, a2::l2) -> let r = f false a1 a2 in r :: map2_last f l1 l2 - | (_, _) -> invalid_arg "List.map2_last" +let set_browser () = + packages_info := Browser +let is_browser () = !packages_info = Browser -let rec map_last f l1 = - match l1 with - | [] -> [] - | [u]-> [f true u ] - | a1::l1 -> let r = f false a1 in r :: map_last f l1 +let get_package_name () = + match !packages_info with + | Empty | Browser -> None + | NonBrowser(n,_) -> Some n +let no_version_header = ref false -let flat_map2_last f lx ly = List.concat @@ map2_last f lx ly +let set_package_name name = + match !packages_info with + | Empty -> packages_info := NonBrowser(name, []) + | _ -> + Ext_pervasives.bad_argf "duplicated flag for -bs-package-name" -let init n f = - Array.to_list (Array.init n f) -let take n l = - let arr = Array.of_list l in - let arr_length = Array.length arr in - if arr_length < n then invalid_arg "Ext_list.take" - else (Array.to_list (Array.sub arr 0 n ), - Array.to_list (Array.sub arr n (arr_length - n))) +let set_npm_package_path s = + match !packages_info with + | Empty -> + Ext_pervasives.bad_argf "please set package name first using -bs-package-name "; + | Browser -> + Ext_pervasives.bad_argf "invalid options, already set to browser "; + | NonBrowser(name, envs) -> + let env, path = + match Ext_string.split ~keep_empty:false s ':' with + | [ package_name; path] -> + (match package_name with + | "commonjs" -> `NodeJS + | "amdjs" -> `AmdJS + | "goog" -> `Goog + | _ -> + Ext_pervasives.bad_argf "invalid module system %s" package_name), path + | [path] -> + `NodeJS, path + | _ -> + Ext_pervasives.bad_argf "invalid npm package path: %s" s + in + packages_info := NonBrowser (name, ((env,path) :: envs)) + (** Browser is not set via command line only for internal use *) -let try_take n l = - let arr = Array.of_list l in - let arr_length = Array.length arr in - if arr_length <= n then - l, arr_length, [] - else Array.to_list (Array.sub arr 0 n ), n, (Array.to_list (Array.sub arr n (arr_length - n))) -let exclude_tail (x : 'a list) : 'a list = - let rec aux acc x = - match x with - | [] -> invalid_arg "Ext_list.exclude_tail" - | [ _ ] -> List.rev acc - | y0::ys -> aux (y0::acc) ys in - aux [] x -(* For small list, only need partial equality - {[ - group (=) [1;2;3;4;3] - ;; - - : int list list = [[3; 3]; [4]; [2]; [1]] - # group (=) [];; - - : 'a list list = [] - ]} - *) -let rec group (cmp : 'a -> 'a -> bool) (lst : 'a list) : 'a list list = - match lst with - | [] -> [] - | x::xs -> - aux cmp x (group cmp xs ) -and aux cmp (x : 'a) (xss : 'a list list) : 'a list list = - match xss with - | [] -> [[x]] - | y::ys -> - if cmp x (List.hd y) (* cannot be null*) then - (x::y) :: ys - else - y :: aux cmp x ys - -let stable_group cmp lst = group cmp lst |> List.rev +let cross_module_inline = ref false -let rec drop n h = - if n < 0 then invalid_arg "Ext_list.drop" - else if n = 0 then h - else if h = [] then invalid_arg "Ext_list.drop" - else - drop (n - 1) (List.tl h) +let get_cross_module_inline () = !cross_module_inline +let set_cross_module_inline b = + cross_module_inline := b -let rec for_all_ret p = function - | [] -> None - | a::l -> - if p a - then for_all_ret p l - else Some a -let rec for_all_opt p = function - | [] -> None - | a::l -> - match p a with - | None -> for_all_opt p l - | v -> v +let diagnose = ref false +let get_diagnose () = !diagnose +let set_diagnose b = diagnose := b -let fold f l init = - List.fold_left (fun acc i -> f i init) init l +let (//) = Filename.concat -let rev_map_acc acc f l = - let rec rmap_f accu = function - | [] -> accu - | a::l -> rmap_f (f a :: accu) l - in - rmap_f acc l +let get_packages_info () = !packages_info -let rec rev_iter f xs = - match xs with - | [] -> () - | y :: ys -> - rev_iter f ys ; - f y - -let rec for_all2_no_exn p l1 l2 = - match (l1, l2) with - | ([], []) -> true - | (a1::l1, a2::l2) -> p a1 a2 && for_all2_no_exn p l1 l2 - | (_, _) -> false +type info_query = + [ `Empty + | `Package_script of string + | `Found of package_name * string + | `NotFound ] +let query_package_infos package_infos module_system = + match package_infos with + | Browser -> + `Empty + | Empty -> `Empty + | NonBrowser (name, []) -> `Package_script name + | NonBrowser (name, paths) -> + begin match List.find (fun (k, _) -> k = module_system) paths with + | (_, x) -> `Found (name, x) + | exception _ -> `NotFound + end +let get_current_package_name_and_path module_system = + query_package_infos !packages_info module_system -let rec find_no_exn p = function - | [] -> None - | x :: l -> if p x then Some x else find_no_exn p l +(* for a single pass compilation, [output_dir] + can be cached +*) +let get_output_dir module_system filename = + match !packages_info with + | Empty | Browser | NonBrowser (_, [])-> + if Filename.is_relative filename then + Lazy.force Ext_filename.cwd // + Filename.dirname filename + else + Filename.dirname filename + | NonBrowser (_, modules) -> + begin match List.find (fun (k,_) -> k = module_system) modules with + | (_, _path) -> Lazy.force Ext_filename.package_dir // _path + | exception _ -> assert false + end -let rec find_opt p = function - | [] -> None - | x :: l -> - match p x with - | Some _ as v -> v - | None -> find_opt p l + + +let default_gen_tds = ref false + +let no_builtin_ppx_ml = ref false +let no_builtin_ppx_mli = ref false -let split_map - ( f : 'a -> ('b * 'c)) (xs : 'a list ) : 'b list * 'c list = - let rec aux bs cs xs = - match xs with - | [] -> List.rev bs, List.rev cs - | u::us -> - let b,c = f u in aux (b::bs) (c ::cs) us in +let stdlib_set = String_set.of_list [ + "arg"; + "gc"; + "printexc"; + "array"; + "genlex"; + "printf"; + "arrayLabels"; + "hashtbl"; + "queue"; + "buffer"; + "int32"; + "random"; + "bytes"; + "int64"; + "scanf"; + "bytesLabels"; + "lazy"; + "set"; + "callback"; + "lexing"; + "sort"; + "camlinternalFormat"; + "list"; + "stack"; + "camlinternalFormatBasics"; + "listLabels"; + "stdLabels"; + "camlinternalLazy"; + "map"; + (* "std_exit"; *) + (* https://developer.mozilla.org/de/docs/Web/Events/beforeunload *) + "camlinternalMod"; + "marshal"; + "stream"; + "camlinternalOO"; + "moreLabels"; + "string"; + "char"; + "nativeint"; + "stringLabels"; + "complex"; + "obj"; + "sys"; + "digest"; + "oo"; + "weak"; + "filename"; + "parsing"; + "format"; + "pervasives" +] - aux [] [] xs + +let builtin_exceptions = "Caml_builtin_exceptions" +let exceptions = "Caml_exceptions" +let io = "Caml_io" +let sys = "Caml_sys" +let lexer = "Caml_lexer" +let parser = "Caml_parser" +let obj_runtime = "Caml_obj" +let array = "Caml_array" +let format = "Caml_format" +let string = "Caml_string" +let float = "Caml_float" +let hash = "Caml_hash" +let oo = "Caml_oo" +let curry = "Curry" +(* let bigarray = "Caml_bigarray" *) +(* let unix = "Caml_unix" *) +let int64 = "Caml_int64" +let md5 = "Caml_md5" +let weak = "Caml_weak" +let backtrace = "Caml_backtrace" +let gc = "Caml_gc" +let int32 = "Caml_int32" +let block = "Block" +let js_primitive = "Js_primitive" +let module_ = "Caml_module" +let version = "0.8.7" -(* - {[ - reduce_from_right (-) [1;2;3];; - - : int = 2 - # reduce_from_right (-) [1;2;3; 4];; - - : int = -2 - # reduce_from_right (-) [1];; - - : int = 1 - # reduce_from_right (-) [1;2;3; 4; 5];; - - : int = 3 - ]} -*) -let reduce_from_right fn lst = - begin match List.rev lst with - | last :: rest -> - List.fold_left (fun x y -> fn y x) last rest - | _ -> invalid_arg "Ext_list.reduce" - end -let reduce_from_left fn lst = - match lst with - | first :: rest -> List.fold_left fn first rest - | _ -> invalid_arg "Ext_list.reduce_from_left" +let runtime_set = + [ + module_; + js_primitive; + block; + int32; + gc ; + backtrace; + builtin_exceptions ; + exceptions ; + io ; + sys ; + lexer ; + parser ; + obj_runtime ; + array ; + format ; + string ; + float ; + hash ; + oo ; + curry ; + (* bigarray ; *) + (* unix ; *) + int64 ; + md5 ; + weak ] |> + List.fold_left (fun acc x -> String_set.add (String.uncapitalize x) acc ) String_set.empty +let current_file = ref "" +let debug_file = ref "" -type 'a t = 'a list ref +let set_current_file f = current_file := f +let get_current_file () = !current_file +let get_module_name () = + Filename.chop_extension + (Filename.basename (String.uncapitalize !current_file)) -let create_ref_empty () = ref [] +let iset_debug_file _ = () +let set_debug_file f = debug_file := f +let get_debug_file () = !debug_file -let ref_top x = - match !x with - | y::_ -> y - | _ -> invalid_arg "Ext_list.ref_top" -let ref_empty x = - match !x with [] -> true | _ -> false +let is_same_file () = + !debug_file <> "" && !debug_file = !current_file -let ref_push x refs = - refs := x :: !refs +let tool_name = "BuckleScript" -let ref_pop refs = - match !refs with - | [] -> invalid_arg "Ext_list.ref_pop" - | x::rest -> - refs := rest ; - x +let check_div_by_zero = ref true +let get_check_div_by_zero () = !check_div_by_zero + +let no_any_assert = ref false + +let set_no_any_assert () = no_any_assert := true +let get_no_any_assert () = !no_any_assert + +let is_windows = + match Sys.os_type with + | "Win32" + | "Cygwin"-> true + | _ -> false end -module String_set : sig -#1 "string_set.mli" +module Ext_list : sig +#1 "ext_list.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -1920,102 +1573,89 @@ module String_set : sig -include Set.S with type elt = string +(** Extension to the standard library [List] module *) + +(** TODO some function are no efficiently implemented. *) -end = struct -#1 "string_set.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 filter_map : ('a -> 'b option) -> 'a list -> 'b list +val excludes : ('a -> bool) -> 'a list -> bool * 'a list +val exclude_with_fact : ('a -> bool) -> 'a list -> 'a option * 'a list +val exclude_with_fact2 : + ('a -> bool) -> ('a -> bool) -> 'a list -> 'a option * 'a option * 'a list +val same_length : 'a list -> 'b list -> bool +val init : int -> (int -> 'a) -> 'a list +val take : int -> 'a list -> 'a list * 'a list +val try_take : int -> 'a list -> 'a list * int * 'a list +val exclude_tail : 'a list -> 'a list +val filter_map2 : ('a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list +val filter_map2i : (int -> 'a -> 'b -> 'c option) -> 'a list -> 'b list -> 'c list +val filter_mapi : (int -> 'a -> 'b option) -> 'a list -> 'b list -include Set.Make(String) +val flat_map2 : ('a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list -end -module Ext_pervasives : sig -#1 "ext_pervasives.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 flat_map : ('a -> 'b list) -> 'a list -> 'b list +val flat_map2_last : (bool -> 'a -> 'b -> 'c list) -> 'a list -> 'b list -> 'c list +val map_last : (bool -> 'a -> 'b) -> 'a list -> 'b list +val stable_group : ('a -> 'a -> bool) -> 'a list -> 'a list list +val drop : int -> 'a list -> 'a list +val for_all_ret : ('a -> bool) -> 'a list -> 'a option +val for_all_opt : ('a -> 'b option) -> 'a list -> 'b option +(** [for_all_opt f l] returns [None] if all return [None], + otherwise returns the first one. + *) +val fold : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b +(** same as [List.fold_left]. + Provide an api so that list can be easily swapped by other containers + *) -(** Extension to standard library [Pervavives] module, safe to open - *) +val rev_map_append : ('a -> 'b) -> 'a list -> 'b list -> 'b list -external reraise: exn -> 'a = "%reraise" -val finally : 'a -> ('a -> 'b) -> ('a -> 'c) -> 'b +val rev_map_acc : 'a list -> ('b -> 'a) -> 'b list -> 'a list -val with_file_as_chan : string -> (out_channel -> 'a) -> 'a +val rev_iter : ('a -> unit) -> 'a list -> unit -val with_file_as_pp : string -> (Format.formatter -> 'a) -> 'a +val for_all2_no_exn : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool -val is_pos_pow : Int32.t -> int +val find_opt : ('a -> 'b option) -> 'a list -> 'b option -val failwithf : loc:string -> ('a, unit, string, 'b) format4 -> 'a +(** [f] is applied follow the list order *) +val split_map : ('a -> 'b * 'c) -> 'a list -> 'b list * 'c list -val invalid_argf : ('a, unit, string, 'b) format4 -> 'a -val bad_argf : ('a, unit, string, 'b) format4 -> 'a +val reduce_from_right : ('a -> 'a -> 'a) -> 'a list -> 'a + +(** [fn] is applied from left to right *) +val reduce_from_left : ('a -> 'a -> 'a) -> 'a list -> 'a +type 'a t = 'a list ref -val dump : 'a -> string +val create_ref_empty : unit -> 'a t + +val ref_top : 'a t -> 'a + +val ref_empty : 'a t -> bool +val ref_push : 'a -> 'a t -> unit + +val ref_pop : 'a t -> 'a end = struct -#1 "ext_pervasives.ml" +#1 "ext_list.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2045,133 +1685,315 @@ end = struct -external reraise: exn -> 'a = "%reraise" -let finally v f action = - match f v with - | exception e -> - action v ; - reraise e - | e -> action v ; e -let with_file_as_chan filename f = - let chan = open_out filename in - finally chan f close_out +let rec filter_map (f: 'a -> 'b option) xs = + match xs with + | [] -> [] + | y :: ys -> + begin match f y with + | None -> filter_map f ys + | Some z -> z :: filter_map f ys + end -let with_file_as_pp filename f = - let chan = open_out filename in - finally chan - (fun chan -> - let fmt = Format.formatter_of_out_channel chan in - let v = f fmt in - Format.pp_print_flush fmt (); - v - ) close_out +let excludes p l = + let excluded = ref false in + let rec aux accu = function + | [] -> List.rev accu + | x :: l -> + if p x then + begin + excluded := true ; + aux accu l + end + else aux (x :: accu) l in + let v = aux [] l in + if !excluded then true, v else false,l +let exclude_with_fact p l = + let excluded = ref None in + let rec aux accu = function + | [] -> List.rev accu + | x :: l -> + if p x then + begin + excluded := Some x ; + aux accu l + end + else aux (x :: accu) l in + let v = aux [] l in + !excluded , if !excluded <> None then v else l -let is_pos_pow n = - let module M = struct exception E end in - let rec aux c (n : Int32.t) = - if n <= 0l then -2 - else if n = 1l then c - else if Int32.logand n 1l = 0l then - aux (c + 1) (Int32.shift_right n 1 ) - else raise M.E in - try aux 0 n with M.E -> -1 -let failwithf ~loc fmt = Format.ksprintf (fun s -> failwith (loc ^ s)) - fmt - -let invalid_argf fmt = Format.ksprintf invalid_arg fmt +(** Make sure [p2 x] and [p1 x] will not hold at the same time *) +let exclude_with_fact2 p1 p2 l = + let excluded1 = ref None in + let excluded2 = ref None in + let rec aux accu = function + | [] -> List.rev accu + | x :: l -> + if p1 x then + begin + excluded1 := Some x ; + aux accu l + end + else if p2 x then + begin + excluded2 := Some x ; + aux accu l + end + else aux (x :: accu) l in + let v = aux [] l in + !excluded1, !excluded2 , if !excluded1 <> None && !excluded2 <> None then v else l -let bad_argf fmt = Format.ksprintf (fun x -> raise (Arg.Bad x ) ) fmt -let rec dump r = - if Obj.is_int r then - string_of_int (Obj.magic r : int) - else (* Block. *) - let rec get_fields acc = function - | 0 -> acc - | n -> let n = n-1 in get_fields (Obj.field r n :: acc) n - in - let rec is_list r = - if Obj.is_int r then - r = Obj.repr 0 (* [] *) - else - let s = Obj.size r and t = Obj.tag r in - t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) - in - let rec get_list r = - if Obj.is_int r then - [] - else - let h = Obj.field r 0 and t = get_list (Obj.field r 1) in - h :: t - in - let opaque name = - (* XXX In future, print the address of value 'r'. Not possible - * in pure OCaml at the moment. *) - "<" ^ name ^ ">" - in - let s = Obj.size r and t = Obj.tag r in - (* From the tag, determine the type of block. *) - match t with - | _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (List.map dump fields) ^ "]" - | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (List.map dump fields) ^ ")" - | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" - | x when x = Obj.closure_tag -> - opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let _clasz, id, slots = - match fields with - | h::h'::t -> h, h', t - | _ -> assert false - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ dump id ^ " (" ^ String.concat ", " (List.map dump slots) ^ ")" - | x when x = Obj.infix_tag -> - opaque "infix" - | x when x = Obj.forward_tag -> - opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ - " (" ^ String.concat ", " (List.map dump fields) ^ ")" - | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" - | x when x = Obj.double_tag -> - string_of_float (Obj.magic r : float) - | x when x = Obj.abstract_tag -> - opaque "abstract" - | x when x = Obj.custom_tag -> - opaque "custom" - | x when x = Obj.custom_tag -> - opaque "final" - | x when x = Obj.double_array_tag -> - "[|"^ - String.concat ";" - (Array.to_list (Array.map string_of_float (Obj.magic r : float array))) ^ - "|]" - | _ -> - opaque (Printf.sprintf "unknown: tag %d size %d" t s) +let rec same_length xs ys = + match xs, ys with + | [], [] -> true + | _::xs, _::ys -> same_length xs ys + | _, _ -> false -let dump v = dump (Obj.repr v) +let filter_mapi (f: int -> 'a -> 'b option) xs = + let rec aux i xs = + match xs with + | [] -> [] + | y :: ys -> + begin match f i y with + | None -> aux (i + 1) ys + | Some z -> z :: aux (i + 1) ys + end in + aux 0 xs + +let rec filter_map2 (f: 'a -> 'b -> 'c option) xs ys = + match xs,ys with + | [],[] -> [] + | u::us, v :: vs -> + begin match f u v with + | None -> filter_map2 f us vs (* idea: rec f us vs instead? *) + | Some z -> z :: filter_map2 f us vs + end + | _ -> invalid_arg "Ext_list.filter_map2" + +let filter_map2i (f: int -> 'a -> 'b -> 'c option) xs ys = + let rec aux i xs ys = + match xs,ys with + | [],[] -> [] + | u::us, v :: vs -> + begin match f i u v with + | None -> aux (i + 1) us vs (* idea: rec f us vs instead? *) + | Some z -> z :: aux (i + 1) us vs + end + | _ -> invalid_arg "Ext_list.filter_map2i" in + aux 0 xs ys + +let rec rev_map_append f l1 l2 = + match l1 with + | [] -> l2 + | a :: l -> rev_map_append f l (f a :: l2) + +let flat_map2 f lx ly = + let rec aux acc lx ly = + match lx, ly with + | [], [] + -> List.rev acc + | x::xs, y::ys + -> aux (List.rev_append (f x y) acc) xs ys + | _, _ -> invalid_arg "Ext_list.flat_map2" in + aux [] lx ly + +let flat_map f lx = + let rec aux acc lx = + match lx with + | [] -> List.rev acc + | y::ys -> aux (List.rev_append ( f y) acc ) ys in + aux [] lx + +let rec map2_last f l1 l2 = + match (l1, l2) with + | ([], []) -> [] + | [u], [v] -> [f true u v ] + | (a1::l1, a2::l2) -> let r = f false a1 a2 in r :: map2_last f l1 l2 + | (_, _) -> invalid_arg "List.map2_last" + +let rec map_last f l1 = + match l1 with + | [] -> [] + | [u]-> [f true u ] + | a1::l1 -> let r = f false a1 in r :: map_last f l1 + + +let flat_map2_last f lx ly = List.concat @@ map2_last f lx ly + +let init n f = + Array.to_list (Array.init n f) + +let take n l = + let arr = Array.of_list l in + let arr_length = Array.length arr in + if arr_length < n then invalid_arg "Ext_list.take" + else (Array.to_list (Array.sub arr 0 n ), + Array.to_list (Array.sub arr n (arr_length - n))) + +let try_take n l = + let arr = Array.of_list l in + let arr_length = Array.length arr in + if arr_length <= n then + l, arr_length, [] + else Array.to_list (Array.sub arr 0 n ), n, (Array.to_list (Array.sub arr n (arr_length - n))) + +let exclude_tail (x : 'a list) : 'a list = + let rec aux acc x = + match x with + | [] -> invalid_arg "Ext_list.exclude_tail" + | [ _ ] -> List.rev acc + | y0::ys -> aux (y0::acc) ys in + aux [] x + +(* For small list, only need partial equality + {[ + group (=) [1;2;3;4;3] + ;; + - : int list list = [[3; 3]; [4]; [2]; [1]] + # group (=) [];; + - : 'a list list = [] + ]} + *) +let rec group (cmp : 'a -> 'a -> bool) (lst : 'a list) : 'a list list = + match lst with + | [] -> [] + | x::xs -> + aux cmp x (group cmp xs ) + +and aux cmp (x : 'a) (xss : 'a list list) : 'a list list = + match xss with + | [] -> [[x]] + | y::ys -> + if cmp x (List.hd y) (* cannot be null*) then + (x::y) :: ys + else + y :: aux cmp x ys + +let stable_group cmp lst = group cmp lst |> List.rev + +let rec drop n h = + if n < 0 then invalid_arg "Ext_list.drop" + else if n = 0 then h + else if h = [] then invalid_arg "Ext_list.drop" + else + drop (n - 1) (List.tl h) + +let rec for_all_ret p = function + | [] -> None + | a::l -> + if p a + then for_all_ret p l + else Some a + +let rec for_all_opt p = function + | [] -> None + | a::l -> + match p a with + | None -> for_all_opt p l + | v -> v + +let fold f l init = + List.fold_left (fun acc i -> f i init) init l + +let rev_map_acc acc f l = + let rec rmap_f accu = function + | [] -> accu + | a::l -> rmap_f (f a :: accu) l + in + rmap_f acc l + +let rec rev_iter f xs = + match xs with + | [] -> () + | y :: ys -> + rev_iter f ys ; + f y + +let rec for_all2_no_exn p l1 l2 = + match (l1, l2) with + | ([], []) -> true + | (a1::l1, a2::l2) -> p a1 a2 && for_all2_no_exn p l1 l2 + | (_, _) -> false + + +let rec find_no_exn p = function + | [] -> None + | x :: l -> if p x then Some x else find_no_exn p l + + +let rec find_opt p = function + | [] -> None + | x :: l -> + match p x with + | Some _ as v -> v + | None -> find_opt p l + + +let split_map + ( f : 'a -> ('b * 'c)) (xs : 'a list ) : 'b list * 'c list = + let rec aux bs cs xs = + match xs with + | [] -> List.rev bs, List.rev cs + | u::us -> + let b,c = f u in aux (b::bs) (c ::cs) us in + + aux [] [] xs + + +(* + {[ + reduce_from_right (-) [1;2;3];; + - : int = 2 + # reduce_from_right (-) [1;2;3; 4];; + - : int = -2 + # reduce_from_right (-) [1];; + - : int = 1 + # reduce_from_right (-) [1;2;3; 4; 5];; + - : int = 3 + ]} +*) +let reduce_from_right fn lst = + begin match List.rev lst with + | last :: rest -> + List.fold_left (fun x y -> fn y x) last rest + | _ -> invalid_arg "Ext_list.reduce" + end +let reduce_from_left fn lst = + match lst with + | first :: rest -> List.fold_left fn first rest + | _ -> invalid_arg "Ext_list.reduce_from_left" + + +type 'a t = 'a list ref +let create_ref_empty () = ref [] + +let ref_top x = + match !x with + | y::_ -> y + | _ -> invalid_arg "Ext_list.ref_top" + +let ref_empty x = + match !x with [] -> true | _ -> false + +let ref_push x refs = + refs := x :: !refs + +let ref_pop refs = + match !refs with + | [] -> invalid_arg "Ext_list.ref_pop" + | x::rest -> + refs := rest ; + x end -module Ext_sys : sig -#1 "ext_sys.mli" +module Ast_literal : sig +#1 "ast_literal.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2196,16 +2018,59 @@ module Ext_sys : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val is_directory_no_exn : string -> bool -end = struct -#1 "ext_sys.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. +type 'a lit = ?loc: Location.t -> unit -> 'a +module Lid : sig + type t = Longident.t + val val_unit : t + val type_unit : t + val pervasives_js_obj : t + + val js_fn : t + val pervasives_fn : t + + val js_meth : t + val pervasives_meth : t + + val pervasives_meth_callback : t + val js_meth_callback : t + val js_obj : t + + val ignore_id : t + val js_null : t + val js_undefined : t + val js_null_undefined : t + + val pervasives_js_undefined : t + + val pervasives_re_id : t + val js_re_id : t + + val js_unsafe : t +end + +type expression_lit = Parsetree.expression lit +type core_type_lit = Parsetree.core_type lit +type pattern_lit = Parsetree.pattern lit + +val val_unit : expression_lit + +val type_unit : core_type_lit + +val type_string : core_type_lit + +val type_any : core_type_lit + +val pat_unit : pattern_lit + +end = struct +#1 "ast_literal.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 @@ -2224,13 +2089,105 @@ 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. *) +open Ast_helper -let is_directory_no_exn f = - try Sys.is_directory f with _ -> false +let pervasives = "Pervasives" +module Lid = struct + type t = Longident.t + let val_unit : t = Lident "()" + let type_unit : t = Lident "unit" + let type_string : t = Lident "string" + (* TODO should be renamed in to {!Js.fn} *) + (* TODO should be moved into {!Js.t} Later *) + + + + let js_fn = Longident.Ldot (Lident "Js", "fn") + let pervasives_fn = Longident.Ldot (Lident pervasives, "js_fn") + + let js_meth = Longident.Ldot (Lident "Js", "meth") + let pervasives_meth = Longident.Ldot (Lident pervasives, "js_meth") + + + let js_meth_callback = Longident.Ldot (Lident "Js", "meth_callback") + let pervasives_meth_callback = Longident.Ldot (Lident pervasives, "js_meth_callback") + + let js_obj = Longident.Ldot (Lident "Js", "t") + let pervasives_js_obj = Longident.Ldot (Lident pervasives, "js_t") + + let ignore_id = Longident.Ldot (Lident pervasives, "ignore") + + let js_null = Longident.Ldot (Lident "Js", "null") + let js_undefined = Longident.Ldot (Lident "Js", "undefined") + let js_null_undefined = Longident.Ldot (Lident "Js", "null_undefined") + + let pervasives_js_null = + Longident.Ldot (Lident pervasives, "js_null") + let pervasives_js_undefined = + Longident.Ldot (Lident pervasives, "js_undefined") + + let pervasives_js_null_undefined = + Longident.Ldot (Lident pervasives, "null_undefined") + + let pervasives_re_id = Longident.Ldot (Lident pervasives, "js_re") + let js_re_id = Longident.Ldot (Lident "Js_re", "t") + let js_unsafe = Longident.Lident "Js_unsafe" end -module Ext_filename : sig -#1 "ext_filename.mli" + +module No_loc = struct + let loc = Location.none + let val_unit = + Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None + let type_unit = + Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) + + let type_string = + Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) + + let type_any = Ast_helper.Typ.any () + let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None +end + +type 'a lit = ?loc: Location.t -> unit -> 'a +type expression_lit = Parsetree.expression lit +type core_type_lit = Parsetree.core_type lit +type pattern_lit = Parsetree.pattern lit + +let val_unit ?loc () = + match loc with + | None -> No_loc.val_unit + | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None + + +let type_unit ?loc () = + match loc with + | None -> + No_loc.type_unit + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) + + +let type_string ?loc () = + match loc with + | None -> No_loc.type_string + | Some loc -> + Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) + +let type_any ?loc () = + match loc with + | None -> No_loc.type_any + | Some loc -> Ast_helper.Typ.any ~loc () + +let pat_unit ?loc () = + match loc with + | None -> No_loc.pat_unit + | Some loc -> + Pat.construct ~loc {txt = Lid.val_unit; loc} None + +end +module Ast_comb : sig +#1 "ast_comb.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2256,49 +2213,46 @@ module Ext_filename : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +val exp_apply_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.expression -> Parsetree.expression list -> Parsetree.expression +val fun_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.pattern -> Parsetree.expression -> Parsetree.expression +val arrow_no_label : + ?loc:Location.t -> + ?attrs:Parsetree.attributes -> + Parsetree.core_type -> Parsetree.core_type -> Parsetree.core_type -(* TODO: - Change the module name, this code is not really an extension of the standard - library but rather specific to JS Module name convention. +(* note we first declare its type is [unit], + then [ignore] it, [ignore] is necessary since + the js value maybe not be of type [unit] and + we can use [unit] value (though very little chance) + sometimes *) +val discard_exp_as_unit : + Location.t -> Parsetree.expression -> Parsetree.expression -type t = - [ `File of string - | `Dir of string ] - -val combine : string -> string -> string -val path_as_directory : string -> string - -(** An extension module to calculate relative path follow node/npm style. - TODO : this short name will have to change upon renaming the file. - *) - -(** Js_output is node style, which means - separator is only '/' - - if the path contains 'node_modules', - [node_relative_path] will discard its prefix and - just treat it as a library instead - *) - -val node_relative_path : t -> [`File of string] -> string - -val chop_extension : ?loc:string -> string -> string - - -val resolve_bs_package : cwd:string -> string -> string +val tuple_type_pair : + ?loc:Ast_helper.loc -> + [< `Make | `Run ] -> + int -> Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type +val to_js_type : + Location.t -> Parsetree.core_type -> Parsetree.core_type -val cwd : string Lazy.t -val package_dir : string Lazy.t -val replace_backward_slash : string -> string +(** TODO: make it work for browser too *) +val to_js_undefined_type : + Location.t -> Parsetree.core_type -> Parsetree.core_type end = struct -#1 "ext_filename.ml" +#1 "ast_comb.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2324,225 +2278,139 @@ end = struct * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Ast_helper +let exp_apply_no_label ?loc ?attrs a b = + Exp.apply ?loc ?attrs a (List.map (fun x -> "", x) b) +let fun_no_label ?loc ?attrs pat body = + Exp.fun_ ?loc ?attrs "" None pat body +let arrow_no_label ?loc ?attrs b c = + Typ.arrow ?loc ?attrs "" b c +let discard_exp_as_unit loc e = + exp_apply_no_label ~loc + (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc}) + [Exp.constraint_ ~loc e + (Ast_literal.type_unit ~loc ())] -(** Used when produce node compatible paths *) -let node_sep = "/" -let node_parent = ".." -let node_current = "." - -type t = - [ `File of string - | `Dir of string ] +let tuple_type_pair ?loc kind arity = + let prefix = "a" in + if arity = 0 then + let ty = Typ.var ?loc ( prefix ^ "0") in + match kind with + | `Run -> ty, [], ty + | `Make -> + (Typ.arrow "" ?loc + (Ast_literal.type_unit ?loc ()) + ty , + [], ty) + else + let number = arity + 1 in + let tys = Ext_list.init number (fun i -> + Typ.var ?loc (prefix ^ string_of_int (number - i - 1)) + ) in + match tys with + | result :: rest -> + Ext_list.reduce_from_left (fun r arg -> Typ.arrow "" ?loc arg r) tys, + List.rev rest , result + | [] -> assert false + + -let cwd = lazy (Sys.getcwd ()) +let js_obj_type_id () = + if Js_config.is_browser () then + Ast_literal.Lid.pervasives_js_obj + else Ast_literal.Lid.js_obj + +let to_js_type loc x = + Typ.constr ~loc {txt = js_obj_type_id (); loc} [x] -let (//) = Filename.concat +let to_js_undefined_type loc x = + Typ.constr ~loc + {txt = Ast_literal.Lid.js_undefined ; loc} + [x] -let combine path1 path2 = - if path1 = "" then - path2 - else if path2 = "" then path1 - else - if Filename.is_relative path2 then - path1// path2 - else - path2 -(* Note that [.//] is the same as [./] *) -let path_as_directory x = - if x = "" then x - else - if Ext_string.ends_with x Filename.dir_sep then - x - else - x ^ Filename.dir_sep - -let absolute_path s = - let process s = - let s = - if Filename.is_relative s then - Lazy.force cwd // s - else s in - (* Now simplify . and .. components *) - let rec aux s = - let base,dir = Filename.basename s, Filename.dirname s in - if dir = s then dir - else if base = Filename.current_dir_name then aux dir - else if base = Filename.parent_dir_name then Filename.dirname (aux dir) - else aux dir // base - in aux s in - match s with - | `File x -> `File (process x ) - | `Dir x -> `Dir (process x) - - -let chop_extension ?(loc="") name = - try Filename.chop_extension name - with Invalid_argument _ -> - Ext_pervasives.invalid_argf - "Filename.chop_extension ( %s : %s )" loc name - -let try_chop_extension s = try Filename.chop_extension s with _ -> s - -(** example - {[ - "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj" - "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml" - ]} - - The other way - {[ - - "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/ocaml_array.ml" - "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib/external/pervasives.cmj" - ]} - {[ - "/bb/mbigc/mbig2899/bgit/bucklescript/jscomp/stdlib//ocaml_array.ml" - ]} - {[ - /a/b - /c/d - ]} - *) -let relative_path file_or_dir_1 file_or_dir_2 = - let sep_char = Filename.dir_sep.[0] in - let relevant_dir1 = - (match file_or_dir_1 with - | `Dir x -> x - | `File file1 -> Filename.dirname file1) in - let relevant_dir2 = - (match file_or_dir_2 with - |`Dir x -> x - |`File file2 -> Filename.dirname file2 ) in - let dir1 = Ext_string.split relevant_dir1 sep_char in - let dir2 = Ext_string.split relevant_dir2 sep_char in - let rec go (dir1 : string list) (dir2 : string list) = - match dir1, dir2 with - | x::xs , y :: ys when x = y - -> go xs ys - | _, _ - -> - List.map (fun _ -> node_parent) dir2 @ dir1 - in - match go dir1 dir2 with - | (x :: _ ) as ys when x = node_parent -> - String.concat node_sep ys - | ys -> - String.concat node_sep @@ node_current :: ys +end +module Literals : sig +#1 "literals.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 node_modules = "node_modules" -let node_modules_length = String.length "node_modules" -let package_json = "package.json" +val js_array_ctor : string +val js_type_number : string +val js_type_string : string +val js_type_object : string +val js_undefined : string +val js_prop_length : string -(** path2: a/b - path1: a - result: ./b - TODO: [Filename.concat] with care +val param : string +val partial_arg : string +val prim : string - [file1] is currently compilation file - [file2] is the dependency - *) -let node_relative_path (file1 : t) - (`File file2 as dep_file : [`File of string]) = - let v = Ext_string.find file2 ~sub:node_modules in - let len = String.length file2 in - if v >= 0 then - let rec skip i = - if i >= len then - Ext_pervasives.failwithf ~loc:__LOC__ "invalid path: %s" file2 - else - match file2.[i] with - | '/' - | '.' -> skip (i + 1) - | _ -> i - (* - TODO: we need do more than this suppose user - input can be - {[ - "xxxghsoghos/ghsoghso/node_modules/../buckle-stdlib/list.js" - ]} - This seems weird though - *) - in - Ext_string.tail_from file2 - (skip (v + node_modules_length)) - else - relative_path - (absolute_path dep_file) - (absolute_path file1) - ^ node_sep ^ - try_chop_extension (Filename.basename file2) +(**temporary varaible used in {!Js_ast_util} *) +val tmp : string +val create : string +val app : string +val app_array : string -(** [resolve cwd module_name], - [cwd] is current working directory, absolute path - Trying to find paths to load [module_name] - it is sepcialized for option [-bs-package-include] which requires - [npm_package_name/lib/ocaml] -*) -let resolve_bs_package ~cwd name = - let sub_path = name // "lib" // "ocaml" in - let rec aux origin cwd name = - let destdir = cwd // node_modules // sub_path in - if Ext_sys.is_directory_no_exn destdir then destdir - else - let cwd' = Filename.dirname cwd in - if String.length cwd' < String.length cwd then - aux origin cwd' name - else - try - let destdir = - Sys.getenv "npm_config_prefix" - // "lib" // node_modules // sub_path in - if Ext_sys.is_directory_no_exn destdir - then destdir - else - Ext_pervasives.failwithf - ~loc:__LOC__ " %s not found in %s" name origin +val runtime : string +val stdlib : string +val imul : string - with - Not_found -> - Ext_pervasives.failwithf - ~loc:__LOC__ " %s not found in %s" name origin - in - aux cwd cwd name +val setter_suffix : string +val setter_suffix_len : int -let find_package_json_dir cwd = - let rec aux cwd = - if Sys.file_exists (cwd // package_json) then cwd - else - let cwd' = Filename.dirname cwd in - if String.length cwd' < String.length cwd then - aux cwd' - else - Ext_pervasives.failwithf - ~loc:__LOC__ - "package.json not found from %s" cwd - in - aux cwd +val js_debugger : string +val js_pure_expr : string +val js_pure_stmt : string +val js_unsafe_downgrade : string +val js_fn_run : string +val js_method_run : string +val js_fn_method : string +val js_fn_mk : string -let package_dir = lazy (find_package_json_dir (Lazy.force cwd)) +(** callback actually, not exposed to user yet *) +val js_fn_runmethod : string -let replace_backward_slash (x : string)= - String.map (function - |'\\'-> '/' - | x -> x) x +val bs_deriving : string +val bs_deriving_dot : string +val bs_type : string -end -module Js_config : sig -#1 "js_config.mli" +end = struct +#1 "literals.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2568,149 +2436,131 @@ module Js_config : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type module_system = - [ `NodeJS | `AmdJS | `Goog ] (* This will be serliazed *) -type package_info = - (module_system * string ) - -type package_name = string -type packages_info = - | Empty - | Browser - | NonBrowser of (package_name * package_info list) -val cmj_ext : string +let js_array_ctor = "Array" +let js_type_number = "number" +let js_type_string = "string" +let js_type_object = "object" +let js_undefined = "undefined" +let js_prop_length = "length" +let prim = "prim" +let param = "param" +let partial_arg = "partial_arg" +let tmp = "tmp" -val is_browser : unit -> bool -val set_browser : unit -> unit - - -val get_ext : unit -> string - -(** depends on [package_infos], used in {!Js_program_loader} *) -val get_output_dir : module_system -> string -> string +let create = "create" (* {!Caml_exceptions.create}*) +let app = "_" +let app_array = "app" (* arguments are an array*) -(** used by command line option *) -val set_npm_package_path : string -> unit -val get_packages_info : unit -> packages_info +let runtime = "runtime" (* runtime directory *) -type info_query = - [ `Empty - | `Package_script of string - | `Found of package_name * string - | `NotFound - ] +let stdlib = "stdlib" -val query_package_infos : - packages_info -> - module_system -> - info_query +let imul = "imul" (* signed int32 mul *) +let setter_suffix = "#=" +let setter_suffix_len = String.length setter_suffix +let js_debugger = "js_debugger" +let js_pure_expr = "js_pure_expr" +let js_pure_stmt = "js_pure_stmt" +let js_unsafe_downgrade = "js_unsafe_downgrade" +let js_fn_run = "js_fn_run" +let js_method_run = "js_method_run" -(** set/get header *) -val no_version_header : bool ref +let js_fn_method = "js_fn_method" +let js_fn_mk = "js_fn_mk" +let js_fn_runmethod = "js_fn_runmethod" +let bs_deriving = "bs.deriving" +let bs_deriving_dot = "bs.deriving." +let bs_type = "bs.type" -(** return [package_name] and [path] - when in script mode: -*) +end +module String_map : sig +#1 "string_map.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 get_current_package_name_and_path : - module_system -> info_query -val set_package_name : string -> unit -val get_package_name : unit -> string option -(** corss module inline option *) -val cross_module_inline : bool ref -val set_cross_module_inline : bool -> unit -val get_cross_module_inline : unit -> bool - -(** diagnose option *) -val diagnose : bool ref -val get_diagnose : unit -> bool -val set_diagnose : bool -> unit -(** generate tds option *) -val default_gen_tds : bool ref -(** options for builtion ppx *) -val no_builtin_ppx_ml : bool ref -val no_builtin_ppx_mli : bool ref -(** check-div-by-zero option *) -val check_div_by_zero : bool ref -val get_check_div_by_zero : unit -> bool +include Map.S with type key = string -(* It will imply [-noassert] be set too, note from the implmentation point of view, - in the lambda layer, it is impossible to tell whehther it is [assert (3 <> 2)] or - [if (3<>2) then assert false] - *) -val no_any_assert : bool ref -val set_no_any_assert : unit -> unit -val get_no_any_assert : unit -> bool +val of_list : (key * 'a) list -> 'a t +end = struct +#1 "string_map.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. *) -(** Internal use *) -val runtime_set : String_set.t -val stdlib_set : String_set.t -(** only used in {!Js_generate_require} *) -val block : string -val int32 : string -val gc : string -val backtrace : string -val version : string -val builtin_exceptions : string -val exceptions : string -val io : string -val oo : string -val sys : string -val lexer : string -val parser : string -val obj_runtime : string -val array : string -val format : string -val string : string -val float : string -val curry : string -(* val bigarray : string *) -(* val unix : string *) -val int64 : string -val md5 : string -val hash : string -val weak : string -val js_primitive : string -val module_ : string -(** Debugging utilies *) -val set_current_file : string -> unit -val get_current_file : unit -> string -val get_module_name : unit -> string -val iset_debug_file : string -> unit -val set_debug_file : string -> unit -val get_debug_file : unit -> string -val is_same_file : unit -> bool -val tool_name : string +include Map.Make(String) -val is_windows : bool +let of_list (xs : ('a * 'b) list ) = + List.fold_left (fun acc (k,v) -> add k v acc) empty xs -end = struct -#1 "js_config.ml" +end +module Ast_payload : sig +#1 "ast_payload.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -2737,297 +2587,708 @@ end = struct +(** A utility module used when destructuring parsetree attributes, used for + compiling FFI attributes and built-in ppx *) +type t = Parsetree.payload +type lid = Longident.t Asttypes.loc +type label_expr = lid * Parsetree.expression +type action = + lid * Parsetree.expression option +val is_single_string : t -> string option +val is_single_int : t -> int option +val as_string_exp : t -> Parsetree.expression option +val as_empty_structure : t -> bool -type env = - | Browser - (* "browser-internal" used internal *) - | NodeJS - | AmdJS - | Goog (* of string option *) - - - -type path = string -type module_system = - [ `NodeJS | `AmdJS | `Goog ] -type package_info = - ( module_system * string ) -type package_name = string -type packages_info = - | Empty (* No set *) - | Browser - | NonBrowser of (package_name * package_info list) -(** we don't force people to use package *) +val assert_strings : + Location.t -> t -> string list +(** as a record or empty + it will accept + {[ [@@@bs.config ]]} + or + {[ [@@@bs.config { property .. } ]]} +*) +val as_record_and_process : + Location.t -> + t -> action list +val assert_bool_lit : Parsetree.expression -> bool -let ext = ref ".js" -let cmj_ext = ".cmj" +val empty : t +val table_dispatch : + (Parsetree.expression option -> 'a) String_map.t -> action -> 'a +end = struct +#1 "ast_payload.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 get_ext () = !ext +type t = Parsetree.payload +let is_single_string (x : t ) = + match x with (** TODO also need detect empty phrase case *) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (name,_)); + _},_); + _}] -> Some name + | _ -> None -let packages_info : packages_info ref = ref Empty +let is_single_int (x : t ) = + match x with (** TODO also need detect empty phrase case *) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_int name); + _},_); + _}] -> Some name + | _ -> None -let set_browser () = - packages_info := Browser -let is_browser () = !packages_info = Browser +let as_string_exp (x : t ) = + match x with (** TODO also need detect empty phrase case *) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (_,_)); + _} as e ,_); + _}] -> Some e + | _ -> None -let get_package_name () = - match !packages_info with - | Empty | Browser -> None - | NonBrowser(n,_) -> Some n +let as_empty_structure (x : t ) = + match x with + | PStr ([]) -> true + | PTyp _ | PPat _ | PStr (_ :: _ ) -> false -let no_version_header = ref false +type lid = Longident.t Asttypes.loc +type label_expr = lid * Parsetree.expression +type action = + lid * Parsetree.expression option -let set_package_name name = - match !packages_info with - | Empty -> packages_info := NonBrowser(name, []) - | _ -> - Ext_pervasives.bad_argf "duplicated flag for -bs-package-name" +let as_record_and_process + loc + x + = + match x with + | Parsetree.PStr + [ {pstr_desc = Pstr_eval + ({pexp_desc = Pexp_record (label_exprs, with_obj) ; pexp_loc = loc}, _); + _ + }] + -> + begin match with_obj with + | None -> + List.map + (fun (x,y) -> + match (x,y) with + | ({Asttypes.txt = Longident.Lident name; loc} ) , + ({Parsetree.pexp_desc = Pexp_ident{txt = Lident name2}} ) + when name2 = name -> + (x, None) + | _ -> (x, Some y)) + label_exprs + | Some _ -> + Location.raise_errorf ~loc "with is not supported" + end + | Parsetree.PStr [] -> [] + | _ -> + Location.raise_errorf ~loc "this is not a valid record config" -let set_npm_package_path s = - match !packages_info with - | Empty -> - Ext_pervasives.bad_argf "please set package name first using -bs-package-name "; - | Browser -> - Ext_pervasives.bad_argf "invalid options, already set to browser "; - | NonBrowser(name, envs) -> - let env, path = - match Ext_string.split ~keep_empty:false s ':' with - | [ package_name; path] -> - (match package_name with - | "commonjs" -> `NodeJS - | "amdjs" -> `AmdJS - | "goog" -> `Goog - | _ -> - Ext_pervasives.bad_argf "invalid module system %s" package_name), path - | [path] -> - `NodeJS, path - | _ -> - Ext_pervasives.bad_argf "invalid npm package path: %s" s - in - packages_info := NonBrowser (name, ((env,path) :: envs)) - (** Browser is not set via command line only for internal use *) +let assert_strings loc (x : t) : string list + = + let module M = struct exception Not_str end in + match x with + | PStr [ {pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_tuple strs; + _},_); + pstr_loc = loc ; + _}] -> + (try + strs |> List.map (fun e -> + match (e : Parsetree.expression) with + | {pexp_desc = Pexp_constant (Const_string (name,_)); _} -> + name + | _ -> raise M.Not_str) + with M.Not_str -> + Location.raise_errorf ~loc "expect string tuple list" + ) + | PStr [ { + pstr_desc = + Pstr_eval ( + {pexp_desc = + Pexp_constant + (Const_string (name,_)); + _},_); + _}] -> [name] + | PStr [] -> [] + | PStr _ + | PTyp _ | PPat _ -> + Location.raise_errorf ~loc "expect string tuple list" +let assert_bool_lit (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_construct ({txt = Lident "true" }, None) + -> true + | Pexp_construct ({txt = Lident "false" }, None) + -> false + | _ -> + Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field" -let cross_module_inline = ref false +let empty : t = Parsetree.PStr [] -let get_cross_module_inline () = !cross_module_inline -let set_cross_module_inline b = - cross_module_inline := b -let diagnose = ref false -let get_diagnose () = !diagnose -let set_diagnose b = diagnose := b +let table_dispatch table (action : action) + = + match action with + | {txt = Lident name; loc }, y -> + begin match String_map.find name table with + | fn -> fn y + | exception _ -> Location.raise_errorf ~loc "%s is not supported" name + end + | { loc ; }, _ -> + Location.raise_errorf ~loc "invalid label for config" -let (//) = Filename.concat +end +module Ast_attributes : sig +#1 "ast_attributes.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. *) +type attr = Parsetree.attribute +type t = attr list -let get_packages_info () = !packages_info +type ('a,'b) st = + { get : 'a option ; + set : 'b option } -type info_query = - [ `Empty - | `Package_script of string - | `Found of package_name * string - | `NotFound ] -let query_package_infos package_infos module_system = - match package_infos with - | Browser -> - `Empty - | Empty -> `Empty - | NonBrowser (name, []) -> `Package_script name - | NonBrowser (name, paths) -> - begin match List.find (fun (k, _) -> k = module_system) paths with - | (_, x) -> `Found (name, x) - | exception _ -> `NotFound - end +val process_method_attributes_rev : + t -> + (bool * bool , [`Get | `No_get ]) st * t -let get_current_package_name_and_path module_system = - query_package_infos !packages_info module_system +val process_attributes_rev : + t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t +val process_class_type_decl_rev : + t -> [ `Nothing | `Has] * t -(* for a single pass compilation, [output_dir] - can be cached -*) -let get_output_dir module_system filename = - match !packages_info with - | Empty | Browser | NonBrowser (_, [])-> - if Filename.is_relative filename then - Lazy.force Ext_filename.cwd // - Filename.dirname filename - else - Filename.dirname filename - | NonBrowser (_, modules) -> - begin match List.find (fun (k,_) -> k = module_system) modules with - | (_, _path) -> Lazy.force Ext_filename.package_dir // _path - | exception _ -> assert false - end +val process_external : t -> bool +val process_bs_type : t -> Parsetree.core_type option * t +type derive_attr = { + explict_nonrec : bool; + bs_deriving : [`Has_deriving of Ast_payload.action list | `Nothing ] +} +val process_bs_string_int : + t -> [`Nothing | `String | `Int] +val process_bs_string_as : + t -> string option +val process_bs_int_as : + t -> int option - - -let default_gen_tds = ref false - -let no_builtin_ppx_ml = ref false -let no_builtin_ppx_mli = ref false -let stdlib_set = String_set.of_list [ - "arg"; - "gc"; - "printexc"; - "array"; - "genlex"; - "printf"; - "arrayLabels"; - "hashtbl"; - "queue"; - "buffer"; - "int32"; - "random"; - "bytes"; - "int64"; - "scanf"; - "bytesLabels"; - "lazy"; - "set"; - "callback"; - "lexing"; - "sort"; - "camlinternalFormat"; - "list"; - "stack"; - "camlinternalFormatBasics"; - "listLabels"; - "stdLabels"; - "camlinternalLazy"; - "map"; - (* "std_exit"; *) - (* https://developer.mozilla.org/de/docs/Web/Events/beforeunload *) - "camlinternalMod"; - "marshal"; - "stream"; - "camlinternalOO"; - "moreLabels"; - "string"; - "char"; - "nativeint"; - "stringLabels"; - "complex"; - "obj"; - "sys"; - "digest"; - "oo"; - "weak"; - "filename"; - "parsing"; - "format"; - "pervasives" -] +val process_derive_type : + t -> derive_attr * t -let builtin_exceptions = "Caml_builtin_exceptions" -let exceptions = "Caml_exceptions" -let io = "Caml_io" -let sys = "Caml_sys" -let lexer = "Caml_lexer" -let parser = "Caml_parser" -let obj_runtime = "Caml_obj" -let array = "Caml_array" -let format = "Caml_format" -let string = "Caml_string" -let float = "Caml_float" -let hash = "Caml_hash" -let oo = "Caml_oo" -let curry = "Curry" -(* let bigarray = "Caml_bigarray" *) -(* let unix = "Caml_unix" *) -let int64 = "Caml_int64" -let md5 = "Caml_md5" -let weak = "Caml_weak" -let backtrace = "Caml_backtrace" -let gc = "Caml_gc" -let int32 = "Caml_int32" -let block = "Block" -let js_primitive = "Js_primitive" -let module_ = "Caml_module" -let version = "0.8.7" +val bs_obj : Parsetree.core_type -> t +val bs : attr +val bs_this : attr +val bs_method : attr +val mk_bs_type : ?loc:Location.t -> Parsetree.core_type -> attr -let runtime_set = - [ - module_; - js_primitive; - block; - int32; - gc ; - backtrace; - builtin_exceptions ; - exceptions ; - io ; - sys ; - lexer ; - parser ; - obj_runtime ; - array ; - format ; - string ; - float ; - hash ; - oo ; - curry ; - (* bigarray ; *) - (* unix ; *) - int64 ; - md5 ; - weak ] |> - List.fold_left (fun acc x -> String_set.add (String.uncapitalize x) acc ) String_set.empty +end = struct +#1 "ast_attributes.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 current_file = ref "" -let debug_file = ref "" +type attr = Parsetree.attribute +type t = attr list -let set_current_file f = current_file := f -let get_current_file () = !current_file -let get_module_name () = - Filename.chop_extension - (Filename.basename (String.uncapitalize !current_file)) +type ('a,'b) st = + { get : 'a option ; + set : 'b option } + + +let process_method_attributes_rev (attrs : t) = + List.fold_left (fun (st,acc) (({txt ; loc}, payload) as attr : attr) -> + + match txt with + | "bs.get" (* [@@bs.get{null; undefined}]*) + -> + let result = + List.fold_left + (fun + (null, undefined) + (({txt ; loc}, opt_expr) : Ast_payload.action) -> + if txt = Lident "null" then + (match opt_expr with + | None -> true + | Some e -> + Ast_payload.assert_bool_lit e), undefined + + else if txt = Lident "undefined" then + null, + (match opt_expr with + | None -> true + | Some e -> + Ast_payload.assert_bool_lit e) + + else Location.raise_errorf ~loc "unsupported predicates" + ) (false, false) (Ast_payload.as_record_and_process loc payload) in + + ({st with get = Some result}, acc ) + + | "bs.set" + -> + let result = + List.fold_left + (fun st (({txt ; loc}, opt_expr) : Ast_payload.action) -> + if txt = Lident "no_get" then + match opt_expr with + | None -> `No_get + | Some e -> + if Ast_payload.assert_bool_lit e then + `No_get + else `Get + else Location.raise_errorf ~loc "unsupported predicates" + ) `Get (Ast_payload.as_record_and_process loc payload) in + (* properties -- void + [@@bs.set{only}] + *) + {st with set = Some result }, acc + | _ -> + (st, attr::acc ) + ) ( {get = None ; set = None}, []) attrs + + +let process_attributes_rev (attrs : t) = + List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> + match txt, st with + | "bs", (`Nothing | `Uncurry) + -> + `Uncurry, acc + | "bs.this", (`Nothing | `Meth_callback) + -> `Meth_callback, acc + | "bs.meth", (`Nothing | `Method) + -> `Method, acc + | "bs", _ + | "bs.this", _ + -> Location.raise_errorf + ~loc + "[@bs.this], [@bs], [@bs.meth] can not be applied at the same time" + | _ , _ -> + st, attr::acc + ) ( `Nothing, []) attrs + +let process_class_type_decl_rev attrs = + List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> + match txt, st with + | "bs", _ + -> + `Has, acc + | _ , _ -> + st, attr::acc + ) ( `Nothing, []) attrs + +let process_external attrs = + List.exists (fun (({txt; }, _) : attr) -> + if Ext_string.starts_with txt "bs." then true + else false + ) attrs + +let process_bs_type attrs = + List.fold_right (fun (attr : attr) (st, acc) -> + match attr with + | {txt = "bs.type" }, PTyp typ + -> + Some typ, acc + | _ -> + st, attr::acc + ) attrs (None, []) + + +type derive_attr = { + explict_nonrec : bool; + bs_deriving : [`Has_deriving of Ast_payload.action list | `Nothing ] +} + +let process_derive_type attrs = + List.fold_left + (fun (st, acc) + (({txt ; loc}, payload as attr): attr) -> + match st, txt with + | {bs_deriving = `Nothing}, "bs.deriving" + -> + {st with + bs_deriving = `Has_deriving + (Ast_payload.as_record_and_process loc payload)}, acc + | {bs_deriving = `Has_deriving _}, "bs.deriving" + -> + Location.raise_errorf ~loc "duplicated bs.deriving attribute" + | _ , _ -> + let st = + if txt = "nonrec" then + { st with explict_nonrec = true } + else st in + st, attr::acc + ) ( {explict_nonrec = false; bs_deriving = `Nothing }, []) attrs + + + +let process_bs_string_int attrs = + List.fold_left + (fun st + (({txt ; loc}, payload ): attr) -> + match txt, st with + | "bs.string", (`Nothing | `String) + -> `String + | "bs.int", (`Nothing | `Int) + -> `Int + | "bs.int", _ + | "bs.string", _ + -> + Location.raise_errorf ~loc "conflict attributes " + | _ , _ -> st + ) `Nothing attrs + +let process_bs_string_as attrs = + List.fold_left + (fun st + (({txt ; loc}, payload ): attr) -> + match txt, st with + | "bs.as", None + -> + begin match Ast_payload.is_single_string payload with + | None -> + Location.raise_errorf ~loc "expect string literal " + | Some _ as v-> v + end + | "bs.as", _ + -> + Location.raise_errorf ~loc "duplicated bs.as " + | _ , _ -> st + ) None attrs + +let process_bs_int_as attrs = + List.fold_left + (fun st + (({txt ; loc}, payload ): attr) -> + match txt, st with + | "bs.as", None + -> + begin match Ast_payload.is_single_int payload with + | None -> + Location.raise_errorf ~loc "expect int literal " + | Some _ as v-> v + end + | "bs.as", _ + -> + Location.raise_errorf ~loc "duplicated bs.as " + | _ , _ -> st + ) None attrs + + +let bs : attr + = {txt = "bs" ; loc = Location.none}, Ast_payload.empty +let bs_this : attr + = {txt = "bs.this" ; loc = Location.none}, Ast_payload.empty + +let bs_method : attr + = {txt = "bs.meth"; loc = Location.none}, Ast_payload.empty + +let mk_bs_type ?(loc=Location.none) ty : attr = + { txt = Literals.bs_type; loc }, PTyp ty + +let bs_obj pval_type : t + = + [{txt = "bs.obj" ; loc = Location.none}, Ast_payload.empty ; + mk_bs_type pval_type + ] + +end +module Ast_core_type : sig +#1 "ast_core_type.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. *) + +type t = Parsetree.core_type + + +val list_of_arrow : t -> t * (string * t ) list +val replace_result : t -> t -> t + +val is_unit : t -> bool +val is_array : t -> bool + +(** for + [x:t] -> "x" + [?x:t] -> "?x" +*) +val label_name : string -> [ `Label of string | `Optional of string | `Empty] + + +val string_type : t -> + [ `Int of (int * int) list | + `NonNullString of (int * string) list | + `NullString of (int * string) list | + `Nothing ] + +(** return a function type *) +val from_labels : + loc:Location.t -> t list -> string list -> t + +type arg_label = + [ `Label of string | `Optional of string | `Empty] + +end = struct +#1 "ast_core_type.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 t = Parsetree.core_type +open Ast_helper +(** TODO check the polymorphic *) +let list_of_arrow (ty : t) = + let rec aux (ty : Parsetree.core_type) acc = + match ty.ptyp_desc with + | Ptyp_arrow(label,t1,t2) -> + aux t2 ((label,t1) ::acc) + | Ptyp_poly(_, ty) -> (* should not happen? *) + aux ty acc + | return_type -> ty, List.rev acc + in aux ty [] + +let replace_result ty result = + let rec aux (ty : Parsetree.core_type) = + match ty with + | { ptyp_desc = + Ptyp_arrow (label,t1,t2) + } -> { ty with ptyp_desc = Ptyp_arrow(label,t1, aux t2)} + | {ptyp_desc = Ptyp_poly(fs,ty)} + -> {ty with ptyp_desc = Ptyp_poly(fs, aux ty)} + | _ -> result in + aux ty + +let is_unit (ty : t ) = + match ty.ptyp_desc with + | Ptyp_constr({txt =Lident "unit"}, []) -> true + | _ -> false + +let is_array (ty : t) = + match ty.ptyp_desc with + | Ptyp_constr({txt =Lident "array"}, [_]) -> true + | _ -> false + +let is_optional l = + String.length l > 0 && l.[0] = '?' + +let label_name l = + if l = "" then `Empty else + if is_optional l + then `Optional (String.sub l 1 (String.length l - 1)) + else `Label l + +let string_type (ty : t) = + match ty with + | {ptyp_desc; ptyp_attributes; ptyp_loc = loc} -> + match Ast_attributes.process_bs_string_int ptyp_attributes with + | `String -> + begin match ptyp_desc with + | Ptyp_variant ( row_fields, Closed, None) + -> + let case, result = + (List.fold_right (fun tag (nullary, acc) -> + match nullary, tag with + | (`Nothing | `Null), Parsetree.Rtag (label, attrs, true, []) + -> + let name = + match Ast_attributes.process_bs_string_as attrs with + | Some name -> name + | None -> label in + `Null, ((Btype.hash_variant label, name) :: acc ) + | (`Nothing | `NonNull), Parsetree.Rtag(label, attrs, false, [ _ ]) + -> + let name = + match Ast_attributes.process_bs_string_as attrs with + | Some name -> name + | None -> label in + `NonNull, ((Btype.hash_variant label, name) :: acc) -let iset_debug_file _ = () -let set_debug_file f = debug_file := f -let get_debug_file () = !debug_file + | _ -> Location.raise_errorf ~loc "Not a valid string type" + ) row_fields (`Nothing, [])) in + begin match case with + | `Nothing -> Location.raise_errorf ~loc "Not a valid string type" + | `Null -> `NullString result + | `NonNull -> `NonNullString result + end + | _ -> Location.raise_errorf ~loc "Not a valid string type" + end + | `Int -> + begin match ptyp_desc with + | Ptyp_variant ( row_fields, Closed, None) + -> + let _, acc = + (List.fold_left + (fun (i,acc) rtag -> + match rtag with + | Parsetree.Rtag (label, attrs, true, []) + -> + let name = + match Ast_attributes.process_bs_int_as attrs with + | Some name -> name + | None -> i in + name + 1, ((Btype.hash_variant label , name):: acc ) + | _ -> Location.raise_errorf ~loc "Not a valid string type" + ) (0, []) row_fields) in + `Int (List.rev acc) + + | _ -> Location.raise_errorf ~loc "Not a valid string type" + end + | `Nothing -> `Nothing + -let is_same_file () = - !debug_file <> "" && !debug_file = !current_file -let tool_name = "BuckleScript" +let from_labels ~loc tyvars (labels : string list) + : t = + let result_type = + Ast_comb.to_js_type loc + (Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed) + in + List.fold_right2 + (fun label tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars result_type -let check_div_by_zero = ref true -let get_check_div_by_zero () = !check_div_by_zero -let no_any_assert = ref false +type arg_label = + [ `Label of string | `Optional of string | `Empty] -let set_no_any_assert () = no_any_assert := true -let get_no_any_assert () = !no_any_assert -let is_windows = - match Sys.os_type with - | "Win32" - | "Cygwin"-> true - | _ -> false end -module Ast_literal : sig -#1 "ast_literal.mli" +module Ext_ref : sig +#1 "ext_ref.mli" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -3052,51 +3313,22 @@ module Ast_literal : sig * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +(** [non_exn_protect ref value f] assusme [f()] + would not raise +*) -type 'a lit = ?loc: Location.t -> unit -> 'a -module Lid : sig - type t = Longident.t - val val_unit : t - val type_unit : t - val pervasives_js_obj : t - - val js_fn : t - val pervasives_fn : t - - val js_meth : t - val pervasives_meth : t - - val pervasives_meth_callback : t - val js_meth_callback : t - val js_obj : t - - val ignore_id : t - val js_null : t - val js_undefined : t - val js_null_undefined : t - - val pervasives_re_id : t - val js_re_id : t - - val js_unsafe : t -end - -type expression_lit = Parsetree.expression lit -type core_type_lit = Parsetree.core_type lit -type pattern_lit = Parsetree.pattern lit - -val val_unit : expression_lit - -val type_unit : core_type_lit - -val type_string : core_type_lit +val non_exn_protect : 'a ref -> 'a -> (unit -> 'b) -> 'b +val protect : 'a ref -> 'a -> (unit -> 'b) -> 'b -val type_any : core_type_lit +val protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c -val pat_unit : pattern_lit +(** [non_exn_protect2 refa refb va vb f ] + assume [f ()] would not raise +*) +val non_exn_protect2 : 'a ref -> 'b ref -> 'a -> 'b -> (unit -> 'c) -> 'c end = struct -#1 "ast_literal.ml" +#1 "ext_ref.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. * * This program is free software: you can redistribute it and/or modify @@ -3121,92 +3353,48 @@ 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. *) -open Ast_helper - -module Lid = struct - type t = Longident.t - let val_unit : t = Lident "()" - let type_unit : t = Lident "unit" - let type_string : t = Lident "string" - (* TODO should be renamed in to {!Js.fn} *) - (* TODO should be moved into {!Js.t} Later *) - - - - let js_fn = Longident.Ldot (Lident "Js", "fn") - let pervasives_fn = Longident.Ldot (Lident "Pervasives", "js_fn") - - let js_meth = Longident.Ldot (Lident "Js", "meth") - let pervasives_meth = Longident.Ldot (Lident "Pervasives", "js_meth") - - - let js_meth_callback = Longident.Ldot (Lident "Js", "meth_callback") - let pervasives_meth_callback = Longident.Ldot (Lident "Pervasives", "js_meth_callback") - - let js_obj = Longident.Ldot (Lident "Js", "t") - let pervasives_js_obj = Longident.Ldot (Lident "Pervasives", "js_t") - - let ignore_id = Longident.Ldot (Lident "Pervasives", "ignore") - - let js_null = Longident.Ldot (Lident "Js", "null") - let js_undefined = Longident.Ldot (Lident "Js", "undefined") - let js_null_undefined = Longident.Ldot (Lident "Js", "null_undefined") - - let pervasives_re_id = Longident.Ldot (Lident "Pervasives", "js_re") - let js_re_id = Longident.Ldot (Lident "Js_re", "t") - - let js_unsafe = Longident.Lident "Js_unsafe" -end - -module No_loc = struct - let loc = Location.none - let val_unit = - Ast_helper.Exp.construct {txt = Lid.val_unit; loc } None - let type_unit = - Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - - let type_string = - Ast_helper.Typ.mk (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) - - let type_any = Ast_helper.Typ.any () - let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None -end - -type 'a lit = ?loc: Location.t -> unit -> 'a -type expression_lit = Parsetree.expression lit -type core_type_lit = Parsetree.core_type lit -type pattern_lit = Parsetree.pattern lit - -let val_unit ?loc () = - match loc with - | None -> No_loc.val_unit - | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None - - -let type_unit ?loc () = - match loc with - | None -> - No_loc.type_unit - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_unit; loc}, [])) - +let non_exn_protect r v body = + let old = !r in + r := v; + let res = body() in + r := old; + res -let type_string ?loc () = - match loc with - | None -> No_loc.type_string - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({ txt = Lid.type_string; loc}, [])) +let protect r v body = + let old = !r in + try + r := v; + let res = body() in + r := old; + res + with x -> + r := old; + raise x -let type_any ?loc () = - match loc with - | None -> No_loc.type_any - | Some loc -> Ast_helper.Typ.any ~loc () +let non_exn_protect2 r1 r2 v1 v2 body = + let old1 = !r1 in + let old2 = !r2 in + r1 := v1; + r2 := v2; + let res = body() in + r1 := old1; + r2 := old2; + res -let pat_unit ?loc () = - match loc with - | None -> No_loc.pat_unit - | Some loc -> - Pat.construct ~loc {txt = Lid.val_unit; loc} None +let protect2 r1 r2 v1 v2 body = + let old1 = !r1 in + let old2 = !r2 in + try + r1 := v1; + r2 := v2; + let res = body() in + r1 := old1; + r2 := old2; + res + with x -> + r1 := old1; + r2 := old2; + raise x end module Lam_methname : sig @@ -3425,8 +3613,8 @@ type arg_type = | `Unit | `Nothing ] -type arg_label = - [ `Label of string | `Optional of string | `Empty] +type arg_label = Ast_core_type.arg_label + type arg_kind = { arg_type : arg_type; @@ -3459,8 +3647,10 @@ type prim = Primitive.description val handle_attributes_as_string : Bs_loc.t -> string -> - Parsetree.core_type -> Ast_attributes.t -> - string -> string list + Ast_core_type.t -> + Ast_attributes.t -> + string -> + Ast_core_type.t * string list val bs_external : string val to_string : t -> string @@ -3529,8 +3719,9 @@ type arg_type = | `Unit | `Nothing ] -type arg_label = - [ `Label of string | `Optional of string | `Empty] + +type arg_label = Ast_core_type.arg_label + type arg_kind = { arg_type : arg_type; @@ -3658,44 +3849,58 @@ let handle_attributes (loc : Bs_loc.t) (pval_prim : string ) (type_annotation : Parsetree.core_type) - (prim_attributes : Ast_attributes.t) (prim_name : string) = - let name_from_payload_or_prim payload = - match Ast_payload.is_single_string payload with - | Some _ as val_name -> val_name - | None -> - if String.length prim_name = 0 then Some pval_prim - else Some prim_name (* need check name *) + (prim_attributes : Ast_attributes.t) (prim_name : string) = + let prim_name_or_pval_prim = + if String.length prim_name = 0 then pval_prim + else prim_name (* need check name *) + in + let name_from_payload_or_prim payload = + match Ast_payload.is_single_string payload with + | Some _ as val_name -> val_name + | None -> Some prim_name_or_pval_prim in - let result_type, arg_types = Ast_core_type.list_of_arrow type_annotation in + let result_type_ty, arg_types_ty = + Ast_core_type.list_of_arrow type_annotation in let st = List.fold_left - (fun - ( st) + (fun st (({txt ; loc}, payload) : Ast_attributes.attr) - -> + -> + (* can be generalized into + {[ + [@@bs.val] + ]} + and combined with + {[ + [@@bs.value] [@@bs.module] + ]} + *) + begin match txt with | "bs.val" -> - (* can be generalized into - {[ - [@@bs.val] - ]} - and combined with - {[ - [@@bs.value] [@@bs.module] - ]} - *) - begin match arg_types with + begin match arg_types_ty with | [] -> {st with val_name = name_from_payload_or_prim payload} | _ -> {st with call_name = name_from_payload_or_prim payload} end - (* | "bs.val" -> {st with call_name = name_from_payload_or_prim payload} *) - | "bs.val_of_module" - -> { st with - val_of_module = - Some { bundle = prim_name ; bind_name = Ast_payload.is_single_string payload} - } + | "bs.module" -> + begin match Ast_payload.assert_strings loc payload with + | [name] -> + {st with external_module_name = + Some {bundle=name; bind_name = None}} + | [bundle;bind_name] -> + {st with external_module_name = + Some {bundle; bind_name = Some bind_name}} + | [] -> + { st with + val_of_module = + Some + { bundle = prim_name_or_pval_prim ; + bind_name = Some pval_prim} + } + | _ -> Location.raise_errorf ~loc "Illegal attributes" + end | "bs.splice" -> {st with splice = true} | "bs.send" -> { st with val_send = name_from_payload_or_prim payload} @@ -3703,20 +3908,12 @@ let handle_attributes {st with set_name = name_from_payload_or_prim payload} | "bs.get" -> {st with get_name = name_from_payload_or_prim payload} - | "bs.module" -> - let external_module_name = - begin match Ast_payload.is_string_or_strings payload with - | `Single name -> Some {bundle=name; bind_name = None} - | `Some [bundle;bind_name] -> - Some {bundle; bind_name = Some bind_name} - | `Some _| `None -> Location.raise_errorf ~loc "Illegal attributes" - end in {st with external_module_name} | "bs.new" -> {st with new_name = name_from_payload_or_prim payload} | "bs.set_index" -> {st with set_index = true} | "bs.get_index"-> {st with get_index = true} | "bs.obj" -> {st with mk_obj = true} | "bs.type" - | _ -> st (* warning*) + | _ -> st (* TODO: warning*) end ) init_st prim_attributes in @@ -3729,8 +3926,8 @@ let handle_attributes List.map (fun (label, ty) -> { arg_label = Ast_core_type.label_name label ; arg_type = aux ty - }) arg_types in - let result_type = aux result_type in + }) arg_types_ty in + let result_type = aux result_type_ty in let ffi = match st with | {mk_obj = true} -> @@ -3810,10 +4007,7 @@ let handle_attributes } -> - let name = - if String.length prim_name = 0 then pval_prim - else prim_name - in + let name = prim_name_or_pval_prim in begin match arg_types with | [] -> Js_global {txt = name; external_module_name} | _ -> Js_call {txt = {splice; name}; external_module_name} @@ -3900,6 +4094,31 @@ let handle_attributes -> Location.raise_errorf ~loc "conflict attributes found" | _ -> Location.raise_errorf ~loc "Illegal attribute found" in check_ffi ~loc ffi; + (match ffi, result_type_ty with + | Obj_create arg_labels , {ptyp_desc = Ptyp_any; _} + -> + let result = + Ast_comb.to_js_type loc @@ + Ast_helper.Typ.object_ ~loc ( + List.fold_right2 (fun arg label acc -> + match arg, label with + | (_, ty), `Label s + -> (s , [], ty) :: acc + | (_, ty), `Optional s + -> + begin match (ty : Ast_core_type.t) with + | {ptyp_desc = + Ptyp_constr({txt = + Ldot (Lident "*predef*", "option") }, + [ty])} + -> + (s, [], Ast_comb.to_js_undefined_type loc ty) :: acc + | _ -> assert false + end + | (_, _), `Empty -> acc + ) arg_types_ty arg_labels []) Closed in + Ast_core_type.replace_result type_annotation result + | _, _ -> type_annotation) , (match ffi , prim_name with | Obj_create _ , _ -> prim_name | _ , "" -> pval_prim @@ -3910,9 +4129,9 @@ let handle_attributes_as_string pval_loc pval_prim typ attrs v = - let prim_name, ffi = - (handle_attributes pval_loc pval_prim typ attrs v ) in - [prim_name; to_string ffi] + let pval_type, prim_name, ffi = + handle_attributes pval_loc pval_prim typ attrs v in + pval_type, [prim_name; to_string ffi] @@ -4051,138 +4270,6 @@ let local_extern_cont loc pexp_loc = loc} ) -end -module Ast_comb : sig -#1 "ast_comb.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 exp_apply_no_label : - ?loc:Location.t -> - ?attrs:Parsetree.attributes -> - Parsetree.expression -> Parsetree.expression list -> Parsetree.expression - -val fun_no_label : - ?loc:Location.t -> - ?attrs:Parsetree.attributes -> - Parsetree.pattern -> Parsetree.expression -> Parsetree.expression - -val arrow_no_label : - ?loc:Location.t -> - ?attrs:Parsetree.attributes -> - Parsetree.core_type -> Parsetree.core_type -> Parsetree.core_type - -(* note we first declare its type is [unit], - then [ignore] it, [ignore] is necessary since - the js value maybe not be of type [unit] and - we can use [unit] value (though very little chance) - sometimes -*) -val discard_exp_as_unit : - Location.t -> Parsetree.expression -> Parsetree.expression - - -val tuple_type_pair : - ?loc:Ast_helper.loc -> - [< `Make | `Run ] -> - int -> Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type - - -end = struct -#1 "ast_comb.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. *) - - -open Ast_helper - -let exp_apply_no_label ?loc ?attrs a b = - Exp.apply ?loc ?attrs a (List.map (fun x -> "", x) b) - -let fun_no_label ?loc ?attrs pat body = - Exp.fun_ ?loc ?attrs "" None pat body - -let arrow_no_label ?loc ?attrs b c = - Typ.arrow ?loc ?attrs "" b c - -let discard_exp_as_unit loc e = - exp_apply_no_label ~loc - (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc}) - [Exp.constraint_ ~loc e - (Ast_literal.type_unit ~loc ())] - - -let tuple_type_pair ?loc kind arity = - let prefix = "a" in - if arity = 0 then - let ty = Typ.var ?loc ( prefix ^ "0") in - match kind with - | `Run -> ty, [], ty - | `Make -> - (Typ.arrow "" ?loc - (Ast_literal.type_unit ?loc ()) - ty , - [], ty) - else - let number = arity + 1 in - let tys = Ext_list.init number (fun i -> - Typ.var ?loc (prefix ^ string_of_int (number - i - 1)) - ) in - match tys with - | result :: rest -> - Ext_list.reduce_from_left (fun r arg -> Typ.arrow "" ?loc arg r) tys, - List.rev rest , result - | [] -> assert false - - - - - - - end module Ast_util : sig #1 "ast_util.mli" @@ -4226,7 +4313,8 @@ type uncurry_expression_gen = Parsetree.expression -> Parsetree.expression_desc) cxt type uncurry_type_gen = - (Parsetree.core_type -> + (string -> (* label for error checking *) + Parsetree.core_type -> Parsetree.core_type -> Parsetree.core_type) cxt @@ -4284,8 +4372,6 @@ val to_method_type : uncurry_type_gen *) val to_method_callback_type : uncurry_type_gen -val to_js_type : - loc -> Parsetree.core_type -> Parsetree.core_type @@ -4346,13 +4432,10 @@ type uncurry_expression_gen = Parsetree.expression -> Parsetree.expression_desc) cxt type uncurry_type_gen = - (Parsetree.core_type -> + (string -> + Parsetree.core_type -> Parsetree.core_type -> Parsetree.core_type) cxt -let js_obj_type_id () = - if Js_config.is_browser () then - Ast_literal.Lid.pervasives_js_obj - else Ast_literal.Lid.js_obj let uncurry_type_id () = if Js_config.is_browser () then @@ -4416,28 +4499,29 @@ let lift_js_method_callback loc *) -let to_js_type loc x = - Typ.constr ~loc {txt = js_obj_type_id (); loc} [x] let arrow = Typ.arrow let js_property loc obj name = if Js_config.is_browser () then - let downgrade ~loc () = - let var = Typ.var ~loc "a" in - Ast_comb.arrow_no_label ~loc - (to_js_type loc var) var - in - Ast_external.local_extern_cont loc - ~pval_prim:[Literals.js_unsafe_downgrade] - ~pval_type:(downgrade ~loc ()) - ~local_fun_name:"cast" - (fun down -> Exp.send ~loc (Exp.apply ~loc down ["", obj]) name ) + let downgrade ~loc () = + let var = Typ.var ~loc "a" in + Ast_comb.arrow_no_label ~loc + (Ast_comb.to_js_type loc var) var + in + Ast_external.local_extern_cont loc + ~pval_prim:[Literals.js_unsafe_downgrade] + ~pval_type:(downgrade ~loc ()) + ~local_fun_name:"cast" + (fun down -> Exp.send ~loc (Exp.apply ~loc down ["", obj]) name ) else Parsetree.Pexp_send - ((Exp.apply (Exp.ident {loc; txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.js_unsafe_downgrade)}) - ["",obj]), name) + ((Exp.apply ~loc + (Exp.ident ~loc + {loc; + txt = Ldot (Ast_literal.Lid.js_unsafe, Literals.js_unsafe_downgrade)}) + ["",obj]), name) (* TODO: have a final checking for property arities @@ -4503,9 +4587,12 @@ let method_apply loc self obj name args = generic_apply `Method loc self obj args (fun loc obj -> Exp.mk ~loc (js_property loc obj name)) -let generic_to_uncurry_type kind loc (mapper : Ast_mapper.mapper) +let generic_to_uncurry_type kind loc (mapper : Ast_mapper.mapper) label (first_arg : Parsetree.core_type) - (typ : Parsetree.core_type) = + (typ : Parsetree.core_type) = + if label <> "" then + Location.raise_errorf ~loc "label is not allowed"; + let rec aux acc (typ : Parsetree.core_type) = (* in general, we should collect [typ] in [int -> typ] before transformation, @@ -4615,16 +4702,6 @@ let to_uncurry_fn = let to_method_callback = generic_to_uncurry_exp `Method_callback -let from_labels ~loc (labels : Asttypes.label list) : Parsetree.core_type = - let arity = List.length labels in - let tyvars = (Ext_list.init arity (fun i -> - Typ.var ~loc ("a" ^ string_of_int i))) in - let result_type = - to_js_type loc - (Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed) - in - List.fold_right2 - (fun label tyvar acc -> arrow ~loc label tyvar acc) labels tyvars result_type let handle_debugger loc payload = if Ast_payload.as_empty_structure payload then @@ -4721,6 +4798,7 @@ let handle_raw_structure loc payload = Location.raise_errorf ~loc "bs.raw can only be applied to a string" end + let record_as_js_object loc (self : Ast_mapper.mapper) @@ -4729,15 +4807,19 @@ let record_as_js_object let labels, args = Ext_list.split_map (fun ({Location.txt ; loc}, e) -> match txt with - | Longident.Lident x -> (x, (x, self.expr self e)) + | Longident.Lident x -> + (x, (x, self.expr self e)) | Ldot _ | Lapply _ -> Location.raise_errorf ~loc "invalid js label " ) label_exprs in + let arity = List.length labels in + let tyvars = (Ext_list.init arity (fun i -> + Typ.var ~loc ("a" ^ string_of_int i))) in - let pval_type = from_labels ~loc labels in + let pval_type = Ast_core_type.from_labels ~loc tyvars labels in let pval_attributes = Ast_attributes.bs_obj pval_type in let local_fun_name = "mk" in - let pval_prim = + let pval_type, pval_prim = Ast_external_attributes.handle_attributes_as_string loc local_fun_name @@ -5504,17 +5586,18 @@ let handle_class_type_field acc = | {get = None; set = None}, _ -> let ty = match ty.ptyp_desc with - | Ptyp_arrow ("", args, body) - -> + | Ptyp_arrow (label, args, body) + -> Ast_util.to_method_type - ty.ptyp_loc self args body + ty.ptyp_loc self label args body - | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow ("", args, body); ptyp_loc}) - -> + | Ptyp_poly (strs, {ptyp_desc = Ptyp_arrow (label, args, body); + ptyp_loc}) + -> {ty with ptyp_desc = Ptyp_poly(strs, Ast_util.to_method_type - ptyp_loc self args body )} + ptyp_loc self label args body )} | _ -> self.typ self ty in @@ -5560,7 +5643,7 @@ let handle_class_type_field acc = private_flag, virtual_flag, Ast_util.to_method_type - loc self ty + loc self "" ty (Ast_literal.type_unit ~loc ()) ); pctf_attributes} @@ -5590,19 +5673,22 @@ let handle_typ Ext_ref.non_exn_protect obj_type_as_js_obj_type true (fun _ -> self.typ self ty ) | {ptyp_attributes ; - ptyp_desc = Ptyp_arrow ("", args, body); + ptyp_desc = Ptyp_arrow (label, args, body); + (* let it go without regard label names, + it will report error later when the label is not empty + *) ptyp_loc = loc } -> begin match Ast_attributes.process_attributes_rev ptyp_attributes with | `Uncurry , ptyp_attributes -> - Ast_util.to_uncurry_type loc self args body - | `Meth_callback, ptyp_attributes -> - Ast_util.to_method_callback_type loc self args body + Ast_util.to_uncurry_type loc self label args body + | `Meth_callback, ptyp_attributes -> + Ast_util.to_method_callback_type loc self label args body | `Method, ptyp_attributes -> - Ast_util.to_method_type loc self args body + Ast_util.to_method_type loc self label args body | `Nothing , _ -> if !uncurry_type then - Ast_util.to_uncurry_type loc self args body + Ast_util.to_uncurry_type loc self label args body else Ast_mapper.default_mapper.typ self ty end @@ -5678,7 +5764,7 @@ let handle_typ with ptyp_desc = Ptyp_object(methods, closed_flag); ptyp_attributes } in if !obj_type_as_js_obj_type then - Ast_util.to_js_type loc inner_type + Ast_comb.to_js_type loc inner_type else inner_type | _ -> super.typ self ty @@ -5888,7 +5974,7 @@ let rec unsafe_mapper : Ast_mapper.mapper = let pval_attributes = (Ast_attributes.mk_bs_type ~loc:pval_loc pval_type) :: pval_attributes in - let pval_prim = + let pval_type, pval_prim = match pval_prim with | [ v ] -> Ast_external_attributes.handle_attributes_as_string @@ -5940,7 +6026,7 @@ let rec unsafe_mapper : Ast_mapper.mapper = when Ast_attributes.process_external pval_attributes -> let pval_type = self.typ self pval_type in - let pval_prim = + let pval_type, pval_prim = match pval_prim with | [ v] -> Ast_external_attributes.handle_attributes_as_string @@ -6453,6 +6539,10 @@ val to_out_channel : out_channel -> t val flush : t -> unit -> unit +val pp_print_queue : + ?pp_sep:(Format.formatter -> unit -> unit) -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a Queue.t -> unit + end = struct #1 "ext_format.ml" (* Copyright (C) 2015-2016 Bloomberg Finance L.P. @@ -6559,6 +6649,9 @@ let flush = pp_print_flush let list = pp_print_list +let rec pp_print_queue ?(pp_sep = pp_print_cut) pp_v ppf q = + Queue.iter (fun q -> pp_v ppf q ; pp_sep ppf ()) q + end module Ident_set : sig #1 "ident_set.mli" @@ -7605,8 +7698,6 @@ type ident = Ident.t type primitive = | Pbytes_to_string | Pbytes_of_string - | Pchar_to_int - | Pchar_of_int | Pgetglobal of ident | Psetglobal of ident | Pmakeblock of int * Lambda.tag_info * Asttypes.mutable_flag @@ -7709,11 +7800,15 @@ type switch = sw_numblocks: int; sw_blocks: (int * t) list; sw_failaction : t option} +and apply_status = + | App_na + | App_ml_full + | App_js_full and apply_info = private { fn : t ; args : t list ; loc : Location.t; - status : Lambda.apply_status + status : apply_status } and prim_info = private @@ -7769,7 +7864,7 @@ type unop = t -> t val var : ident -> t val const : Lambda.structured_constant -> t -val apply : t -> t list -> Location.t -> Lambda.apply_status -> t +val apply : t -> t list -> Location.t -> apply_status -> t val function_ : arity:int -> kind:Lambda.function_kind -> params:ident list -> body:t -> t @@ -7860,8 +7955,6 @@ type ident = Ident.t type primitive = | Pbytes_to_string | Pbytes_of_string - | Pchar_to_int - | Pchar_of_int (* Globals *) | Pgetglobal of ident | Psetglobal of ident @@ -7977,11 +8070,15 @@ and prim_info = { primitive : primitive ; args : t list ; } +and apply_status = + | App_na + | App_ml_full + | App_js_full and apply_info = { fn : t ; args : t list ; loc : Location.t; - status : Lambda.apply_status + status : apply_status } and function_info = { arity : int ; @@ -8015,6 +8112,7 @@ and t = *) + module Prim = struct type t = primitive let mk name arity = @@ -8037,7 +8135,6 @@ end - type binop = t -> t -> t type triop = t -> t -> t -> t @@ -8331,10 +8428,6 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args : t = | Pbytes_to_string -> prim ~primitive:Pbytes_to_string ~args | Pbytes_of_string -> prim ~primitive:Pbytes_of_string ~args - | Pchar_to_int -> prim ~primitive:Pchar_to_int ~args - | Pchar_of_int -> prim ~primitive:Pchar_of_int ~args - | Pmark_ocaml_object -> - begin match args with [l] -> l | _ -> assert false end | Pignore -> (* Pignore means return unit, it is not an nop *) begin match args with [x] -> seq x unit | _ -> assert false end | Prevapply loc @@ -8491,7 +8584,7 @@ let rec convert (lam : Lambda.lambda) : t = | Lvar x -> Lvar x | Lconst x -> Lconst x - | Lapply (fn,args,info) + | Lapply (fn,args,loc) -> begin match fn with | Lprim ( @@ -8528,7 +8621,7 @@ let rec convert (lam : Lambda.lambda) : t = end | _ -> apply (convert fn) (List.map convert args) - info.apply_loc info.apply_status + loc App_na end | Lfunction (kind, params,body) -> function_ @@ -9111,8 +9204,6 @@ let primitive ppf (prim : Lam.primitive) = match prim with | Pjs_fn_method i -> fprintf ppf "js_fn_method_%i" i | Pjs_fn_runmethod i -> fprintf ppf "js_fn_runmethod_%i" i | Pdebugger -> fprintf ppf "debugger" - | Pchar_to_int -> fprintf ppf "char_to_int" - | Pchar_of_int -> fprintf ppf "char_of_int" | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, _, Immutable) -> fprintf ppf "makeblock %i" tag @@ -9913,8 +10004,7 @@ let rec no_side_effects (lam : Lam.t) : bool = | Pbytes_to_string | Pbytes_of_string - | Pchar_to_int (* might throw .. *) - | Pchar_of_int + | Pgetglobal _ @@ -11388,7 +11478,7 @@ val is_function : Lam.t -> bool val eta_conversion : int -> - Location.t -> Lambda.apply_status -> Lam.t -> Lam.t list -> Lam.t + Location.t -> Lam.apply_status -> Lam.t -> Lam.t list -> Lam.t @@ -15846,6 +15936,93 @@ let cmj_data_sets = String_map.of_list [ ("typed_array.cmj",lazy (Js_cmj_format.from_string "BUCKLE20160510\132\149\166\190\000\000\000{\000\000\000\022\000\000\000S\000\000\000J\176\208\208\208@-Float32_array\160@@@A-Float64_array\160@@@B+Int32_array\160@@@C@\144\160+bs-platform\160\160\0025d\024\161)lib/amdjs\160\160\002/B\193`(lib/goog\160\160\002\219\182\195k&lib/js@")); ] +end +module Bs_exception : sig +#1 "bs_exception.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. *) + +type error = + | Cmj_not_found of string + | Bs_cyclic_depends of string list + +val error : error -> 'a + +end = struct +#1 "bs_exception.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 error = + | Cmj_not_found of string + | Bs_cyclic_depends of string list + +exception Error of error + +let error err = raise (Error err) + +let report_error ppf = function + | Cmj_not_found s -> + Format.fprintf ppf "%s not found, cmj format is generated by BuckleScript" s + | Bs_cyclic_depends str + -> + Format.fprintf ppf "Cyclic depends : @[%a@]" + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Format.pp_print_string) + str + +let () = + Location.register_error_of_exn + (function + | Error err + -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) + + end module Config_util : sig #1 "config_util.mli" @@ -15960,8 +16137,9 @@ let find_cmj file = -> Ext_log.warn __LOC__ "@[%s not found @]" file ; Js_cmj_format.no_pure_dummy - else - Ext_pervasives.failwithf ~loc:__LOC__ "@[ %s not found @]" file + else + Bs_exception.error (Cmj_not_found file) + end @@ -17067,13 +17245,15 @@ module Ast_extract : sig * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + type ast = | Ml of Parsetree.structure * string (* outputprefix *) | Mli of Parsetree.signature * string (* outputprefix *) type info = - { source_file : string ; - ast : ast + { source_file : string; + ast : ast; + module_name : string } (** @@ -17088,8 +17268,10 @@ type info = for mapping, the key is the module and value is filename *) -val prepare : - (string, ast) Hashtbl.t -> string list * (string, string) Hashtbl.t +val prepare : + (string, ast) Hashtbl.t -> string Queue.t * (string, string) Hashtbl.t + + @@ -17121,11 +17303,11 @@ end = struct +module String_set = Depend.StringSet - -let read_parse_and_extract ast extract_function : Depend.StringSet.t = - Depend.free_structure_names := Depend.StringSet.empty; - (let bound_vars = Depend.StringSet.empty in +let read_parse_and_extract ast extract_function : String_set.t = + Depend.free_structure_names := String_set.empty; + (let bound_vars = String_set.empty in List.iter (fun modname -> Depend.open_module bound_vars (Longident.Lident modname)) @@ -17142,93 +17324,98 @@ type ast = type info = { source_file : string ; - ast : ast + ast : ast; + module_name : string } -let file_dependencies (files : (info * Depend.StringSet.t) list ref) - source_file ast = - let extracted_deps = - read_parse_and_extract ast - ( match ast with - | Ml (ast,_) -> fun set _ -> Depend.add_implementation set ast - | Mli (ast,_) -> fun set _ -> Depend.add_signature set ast ) in - files := ({source_file ; ast }, extracted_deps) :: !files - -let normalize tbl file = - let module_name = +let module_name_of_file file = String.capitalize - (Filename.chop_extension @@ Filename.basename file) in - Hashtbl.add tbl module_name file; - (* could have both mli and ml *) - module_name + (Filename.chop_extension @@ Filename.basename file) -let merge tbl (files : (info * Depend.StringSet.t) list ) : - (string, Depend.StringSet.t) Hashtbl.t - = +let merge (files : (info * String_set.t) list ) = + let tbl = Hashtbl.create 31 in + let domain = + List.fold_left + (fun acc ({ source_file ; module_name}, _) + -> + Hashtbl.add tbl module_name source_file; + String_set.add module_name acc + ) String_set.empty files in - let domain = - Depend.StringSet.of_list - (List.map (fun ({ source_file },_)-> normalize tbl source_file) files) in - let local_tbl = Hashtbl.create 31 in - List.iter - (fun ({source_file = file; _}, deps) -> - let modname = String.capitalize - (Filename.chop_extension @@ Filename.basename file) in - match Hashtbl.find local_tbl modname with + tbl,domain, List.fold_left + (fun acc ({source_file = file; module_name ; _}, deps) -> + match String_map.find module_name acc with | new_deps -> - Hashtbl.replace local_tbl modname - (Depend.StringSet.inter domain - (Depend.StringSet.union deps new_deps)) + String_map.add module_name + (String_set.inter domain + (String_set.union deps new_deps)) acc | exception Not_found -> - Hashtbl.add local_tbl modname (Depend.StringSet.inter deps domain) - ) files ; - local_tbl - - -let sort_files_by_dependencies tbl files - = - let h = merge tbl files in - let worklist = Ext_list.create_ref_empty () in - let ()= - Hashtbl.iter (fun key _ -> Ext_list.ref_push key worklist) h in - let result = Ext_list.create_ref_empty () in - let visited = Hashtbl.create 31 in - while not @@ Ext_list.ref_empty worklist do - let current = Ext_list.ref_top worklist in + String_map.add module_name + (String_set.inter deps domain) acc + ) String_map.empty files + + + + +let sort_files_by_dependencies files + = + let tbl, domain, h = merge files in + let next current = + String_set.elements (String_map.find current h) in + let worklist = ref domain in + + let result = Queue.create () in + let visited = Hashtbl.create 31 in (* Temporary mark *) + + (* only visit nodes that are currently in the domain *) + (* https://en.wikipedia.org/wiki/Topological_sorting *) + (* dfs *) + let rec visit path current = if Hashtbl.mem visited current then - ignore (Ext_list.ref_pop worklist) - else - match Depend.StringSet.elements (Hashtbl.find h current) with - | depends -> - let really_depends = - List.filter - (fun x -> (Hashtbl.mem h x && (not (Hashtbl.mem visited x )))) - depends in - begin match really_depends with - |[] -> - begin - let v = Ext_list.ref_pop worklist in - Hashtbl.add visited v () ; - Ext_list.ref_push current result - end - | _ -> - List.iter (fun x -> Ext_list.ref_push x worklist) really_depends - end - | exception Not_found -> assert false + Bs_exception.error (Bs_cyclic_depends path) + else if String_set.mem current !worklist then + begin + Hashtbl.add visited current () ; + let depends = next current in + List.iter + (fun node -> + if String_map.mem node h then + visit (current::path) node) + depends ; + worklist := String_set.remove current !worklist; + Queue.push current result ; + Hashtbl.remove visited current; + end in + while not (String_set.is_empty !worklist) do + visit [] (String_set.choose !worklist) done; - result + if Js_config.get_diagnose () then + Format.fprintf Format.err_formatter + "Order: @[%a@]@." + (Ext_format.pp_print_queue + ~pp_sep:Format.pp_print_space + Format.pp_print_string) + result ; + result,tbl ;; let prepare ast_table = - let tbl = Hashtbl.create 31 in - let files = ref [] in - Hashtbl.iter (fun sourcefile ast -> file_dependencies files sourcefile ast) ast_table; - let stack = sort_files_by_dependencies tbl !files in - !stack, tbl + let file_dependencies + source_file ast acc = + let extracted_deps = + read_parse_and_extract ast + ( match ast with + | Ml (ast,_) -> fun set _ -> Depend.add_implementation set ast + | Mli (ast,_) -> fun set _ -> Depend.add_signature set ast ) in + ({source_file ; ast ; module_name = module_name_of_file source_file }, + extracted_deps) :: acc in + let files = Hashtbl.fold file_dependencies ast_table [] in + sort_files_by_dependencies files + end @@ -23675,16 +23862,6 @@ let translate | [range; e] -> E.is_out e range | _ -> assert false end - | Pchar_of_int -> - begin match args with - | [e] -> Js_of_lam_string.caml_char_of_int e - | _ -> assert false - end - | Pchar_to_int -> - begin match args with - | [e] -> Js_of_lam_string.caml_char_to_int e - | _ -> assert false - end | Pbytes_of_string -> begin (* TODO: write a js primitive - or is it necessary ? @@ -31321,7 +31498,9 @@ let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg; arg -let after_parsing_sig ppf sourcefile outputprefix ast = +let after_parsing_sig ppf sourcefile outputprefix ast = + if Js_config.get_diagnose () then + Format.fprintf Format.err_formatter "Building %s@." sourcefile; let modulename = module_of_filename ppf sourcefile outputprefix in let initial_env = Compmisc.initial_env () in Env.set_unit_name modulename; @@ -31349,6 +31528,8 @@ let interface ppf sourcefile outputprefix = |> after_parsing_sig ppf sourcefile outputprefix let after_parsing_impl ppf sourcefile outputprefix ast = + if Js_config.get_diagnose () then + Format.fprintf Format.err_formatter "Building %s@." sourcefile; let modulename = Compenv.module_of_filename ppf sourcefile outputprefix in let env = Compmisc.initial_env() in Env.set_unit_name modulename; @@ -31372,14 +31553,17 @@ let after_parsing_impl ppf sourcefile outputprefix ast = sourcefile outputprefix lambda with | e -> e | exception e -> - (* Save to a file instead so that it will not scare user *) - let file = "bsc.dump" in - Ext_pervasives.with_file_as_chan file - (fun ch -> output_string ch @@ - Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())); - Ext_log.err __LOC__ - "Compilation fatal error, stacktrace saved into %s when compiling %s" - file sourcefile; + (* Save to a file instead so that it will not scare user *) + if Js_config.get_diagnose () then + begin + let file = "bsc.dump" in + Ext_pervasives.with_file_as_chan file + (fun ch -> output_string ch @@ + Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())); + Ext_log.err __LOC__ + "Compilation fatal error, stacktrace saved into %s when compiling %s" + file sourcefile; + end; raise e ); end; @@ -31469,9 +31653,8 @@ let batch_compile ppf files = (Mli (Ocaml_parse.parse_interface ppf name, opref)) end; - let stack,mapping = Ast_extract.prepare batch_files in - stack |> Ext_list.rev_iter (fun modname -> - (* prerr_endline ("compiling " ^ modname); *) + let stack, mapping = Ast_extract.prepare batch_files in + stack |> Queue.iter (fun modname -> match Hashtbl.find_all mapping modname with | [] -> () | [sourcefile] ->