diff --git a/jscomp/core/lam_pass_eliminate_ref.ml b/jscomp/core/lam_pass_eliminate_ref.ml index a5e3a333365..4ae7656141c 100644 --- a/jscomp/core/lam_pass_eliminate_ref.ml +++ b/jscomp/core/lam_pass_eliminate_ref.ml @@ -23,7 +23,7 @@ let rec eliminate_ref id (lam : Lam.t) = | Lprim {primitive = Pfield (0,_); args = [Lvar v]} when Ident.same v id -> Lam.var id | Lfunction{ function_kind; params; body} as lam -> - if Ident_set.mem id (Lam.free_variables lam) + if Ident_set.mem id (Lam.free_variables lam) (*TODO: optmization: no need construct*) then raise_notrace Real_reference else lam (* In Javascript backend, its okay, we can reify it later diff --git a/jscomp/others/.depend b/jscomp/others/.depend index b4e1c2cd780..c0f16ed7c4e 100644 --- a/jscomp/others/.depend +++ b/jscomp/others/.depend @@ -17,8 +17,10 @@ js_console.cmj : js_result.cmj : js_result.cmi js_mapperRt.cmj : js_mapperRt.cmi bs_Array.cmj : js_math.cmj bs_Array.cmi -bs_internalAVLset.cmj : bs_Cmp.cmj bs_Array.cmj bs_internalAVLset.cmi -bs_internalAVLtree.cmj : bs_Array.cmj bs_internalAVLtree.cmi +bs_internalAVLset.cmj : bs_Sort.cmj bs_Cmp.cmj bs_Array.cmj \ + bs_internalAVLset.cmi +bs_internalAVLtree.cmj : bs_Sort.cmj bs_Cmp.cmj bs_Array.cmj \ + bs_internalAVLtree.cmi bs_SetIntM.cmj : bs_internalSetInt.cmj bs_internalAVLset.cmj bs_SortInt.cmj \ bs_Array.cmj bs_SetIntM.cmi bs_Hash.cmj : bs_Hash.cmi @@ -43,16 +45,26 @@ bs_HashSetInt.cmj : bs_internalSetBuckets.cmj bs_internalBucketsType.cmj \ bs_Bag.cmj : bs_BagM.cmj : bs_Cmp.cmj : bs_Cmp.cmi -bs_Map.cmj : bs_internalAVLtree.cmj bs_Cmp.cmj bs_Bag.cmj bs_Array.cmj \ - bs_Map.cmi -bs_MapString.cmj : bs_internalAVLtree.cmj bs_Array.cmj bs_MapString.cmi -bs_MapInt.cmj : bs_internalAVLtree.cmj bs_Array.cmj bs_MapInt.cmi +bs_Map.cmj : bs_internalAVLtree.cmj bs_Cmp.cmj bs_Bag.cmj bs_Map.cmi +bs_internalMapInt.cmj : bs_internalAVLtree.cmj bs_Sort.cmj bs_Array.cmj +bs_internalMapString.cmj : bs_internalAVLtree.cmj bs_Sort.cmj bs_Array.cmj +bs_MapString.cmj : bs_internalMapString.cmj bs_internalAVLtree.cmj \ + bs_Sort.cmj bs_Array.cmj bs_MapString.cmi +bs_MapInt.cmj : bs_internalMapInt.cmj bs_internalAVLtree.cmj bs_Sort.cmj \ + bs_Array.cmj bs_MapInt.cmi +bs_MapStringM.cmj : bs_internalMapString.cmj bs_internalAVLtree.cmj \ + bs_SortString.cmj bs_Array.cmj bs_MapStringM.cmi +bs_MapIntM.cmj : bs_internalMapInt.cmj bs_internalAVLtree.cmj bs_SortInt.cmj \ + bs_Array.cmj bs_MapIntM.cmi bs_Set.cmj : bs_internalAVLset.cmj bs_Cmp.cmj bs_Bag.cmj bs_Array.cmj \ bs_Set.cmi bs_SetM.cmj : bs_internalAVLset.cmj bs_Sort.cmj bs_Cmp.cmj bs_BagM.cmj \ bs_Array.cmj bs_SetM.cmi -bs_internalSetInt.cmj : bs_internalAVLset.cmj bs_Array.cmj -bs_internalSetString.cmj : bs_internalAVLset.cmj bs_Array.cmj +bs_MapM.cmj : bs_internalAVLtree.cmj bs_Cmp.cmj bs_BagM.cmj bs_Array.cmj \ + bs_MapM.cmi +bs_internalSetInt.cmj : bs_internalAVLset.cmj bs_SortInt.cmj bs_Array.cmj +bs_internalSetString.cmj : bs_internalAVLset.cmj bs_SortString.cmj \ + bs_Array.cmj bs_SetInt.cmj : bs_internalSetInt.cmj bs_internalAVLset.cmj bs_SetInt.cmi bs_SetIntM.cmj : bs_internalSetInt.cmj bs_internalAVLset.cmj bs_SortInt.cmj \ bs_Array.cmj bs_SetIntM.cmi @@ -87,7 +99,7 @@ js_result.cmi : js_mapperRt.cmi : bs_Array.cmi : bs_internalAVLset.cmi : bs_Cmp.cmi -bs_internalAVLtree.cmi : +bs_internalAVLtree.cmi : bs_Cmp.cmi bs_SetIntM.cmi : bs_Hash.cmi : bs_Queue.cmi : @@ -104,8 +116,11 @@ bs_Cmp.cmi : bs_Map.cmi : bs_Cmp.cmi bs_Bag.cmj bs_MapString.cmi : bs_MapInt.cmi : +bs_MapStringM.cmi : +bs_MapIntM.cmi : bs_Set.cmi : bs_Cmp.cmi bs_Bag.cmj bs_SetM.cmi : bs_Cmp.cmi +bs_MapM.cmi : bs_Cmp.cmi bs_SetInt.cmi : bs_SetIntM.cmi : bs_SetString.cmi : diff --git a/jscomp/others/Design.md b/jscomp/others/Design.md index 763f635f4ca..0447c3e6c9f 100644 --- a/jscomp/others/Design.md +++ b/jscomp/others/Design.md @@ -36,4 +36,19 @@ hierachy ## bs_SetIntM ## bs_SetStringM -# map \ No newline at end of file +# map +## bs_internalAVLtree (basic module with rotation) + +## bs_Map + +## internal_map.cpp.ml +## bs_internalMapInt +## bs_internalMapString + +## map.cppo.ml +## bs_MapInt +## bs_MapString + +## mapm.cppo.ml +## bs_MapIntM +## bs_MapStringM \ No newline at end of file diff --git a/jscomp/others/Makefile b/jscomp/others/Makefile index 288d7cdfed3..27b0240f62b 100644 --- a/jscomp/others/Makefile +++ b/jscomp/others/Makefile @@ -32,11 +32,16 @@ SOURCE_LIST= node_path node_fs node_process dict node_module js_array js_string bs_BagM\ bs_Cmp\ bs_Map\ + bs_internalMapInt\ + bs_internalMapString\ bs_MapString \ bs_MapInt\ + bs_MapStringM \ + bs_MapIntM\ bs_internalSet\ bs_Set\ bs_SetM\ + bs_MapM\ bs_internalSetInt\ bs_internalSetString\ bs_SetInt\ @@ -86,7 +91,13 @@ clean:: bs_internalSetInt.ml bs_internalSetString.ml \ bs_SetInt.ml bs_SetInt.mli bs_SetString.ml bs_SetString.mli \ bs_SetIntM.ml bs_SetIntM.mli bs_SetStringM.ml bs_SetStringM.mli\ - bs_SortInt.ml bs_SortInt.mli bs_SortString.ml bs_SortString.mli + bs_SortInt.ml bs_SortInt.mli bs_SortString.ml bs_SortString.mli\ + bs_internalMapInt.ml bs_internalMapInt.mli \ + bs_internalMapIntM.ml bs_internalMapIntM.mli \ + bs_internalMapString.ml bs_internalMapString.mli\ + bs_internalMapStringM.ml bs_internalMapStringM.mli\ + bs_MapStringM.mli bs_MapStringM.ml\ + bs_MapIntM.mli bs_MapIntM.ml ifndef BS_RELEASE_BUILD bs_HashSetString.ml: hashset.cppo.ml @@ -113,6 +124,18 @@ bs_MapString.mli: map.cppo.mli cppo -D TYPE_STRING $^ > $@ bs_MapInt.mli: map.cppo.mli cppo -D TYPE_INT $^ > $@ +bs_MapStringM.mli: mapm.cppo.mli + cppo -D TYPE_STRING $^ > $@ +bs_MapIntM.mli: mapm.cppo.mli + cppo -D TYPE_INT $^ > $@ +bs_MapStringM.ml: mapm.cppo.ml + cppo -D TYPE_STRING $^ > $@ +bs_MapIntM.ml: mapm.cppo.ml + cppo -D TYPE_INT $^ > $@ +bs_internalMapInt.ml : internal_map.cppo.ml + cppo -D TYPE_INT $^ > $@ +bs_internalMapString.ml : internal_map.cppo.ml + cppo -D TYPE_STRING $^ > $@ bs_internalSetInt.ml: internal_set.cppo.ml cppo -D TYPE_INT $^ > $@ bs_internalSetString.ml: internal_set.cppo.ml diff --git a/jscomp/others/bs_Array.ml b/jscomp/others/bs_Array.ml index 7fe98222c1b..ee040118439 100644 --- a/jscomp/others/bs_Array.ml +++ b/jscomp/others/bs_Array.ml @@ -45,12 +45,14 @@ let swapUnsafe xs i j = unsafe_set xs j tmp -let shuffleInPlace xs = +let shuffleOnly xs = let len = length xs in for i = 0 to len - 1 do swapUnsafe xs i (Js_math.random_int i len) (* [i,len)*) done +let shuffle xs = shuffleOnly xs; xs + let makeMatrix sx sy init = [%assert sx >=0 && sy >=0 ]; let res = makeUninitializedUnsafe sx in diff --git a/jscomp/others/bs_Array.mli b/jscomp/others/bs_Array.mli index 2b5cb76aff1..32f5a3e9a6b 100644 --- a/jscomp/others/bs_Array.mli +++ b/jscomp/others/bs_Array.mli @@ -39,8 +39,12 @@ external makeUninitializedUnsafe : int -> 'a array = "Array" [@@bs.new] val init : int -> (int -> 'a [@bs]) -> 'a array -val shuffleInPlace : 'a array -> unit +val shuffleOnly : 'a array -> unit +val shuffle :'a array -> 'a array +(** [shuffle xs] it mutates [xs] and return + [xs] for chaining + *) val zip : 'a array -> 'b array -> ('a * 'b) array (** [zip a b] stop with the shorter array *) diff --git a/jscomp/others/bs_Map.ml b/jscomp/others/bs_Map.ml index 85bb43eff65..601d67db6b3 100644 --- a/jscomp/others/bs_Map.ml +++ b/jscomp/others/bs_Map.ml @@ -14,89 +14,70 @@ module N = Bs_internalAVLtree module B = Bs_Bag -type ('key, 'a, 'id) t0 = ('key,'a) N.t0 + +type ('key, 'a, 'id) t0 = ('key, 'a) N.t0 type ('k,'v,'id) t = (('k,'id) Bs_Cmp.t, ('k,'v, 'id) t0 ) B.bag - - -let empty0 = N.empty0 -let isEmpty0 = N.isEmpty0 -let singleton0 = N.singleton0 -let minBinding0 = N.minKVOpt0 -let maxBinding0 = N.maxKVOpt0 -let iter0 = N.iter0 -let map0 = N.map0 -let mapi0 = N.mapi0 -let fold0 = N.fold0 -let forAll0 = N.forAll0 -let exists0 = N.exists0 -let filter0 = N.filter0 -let partition0 = N.partition0 -let length0 = N.length0 -let toList0 = N.toList0 - -let rec add0 (t : _ t0) x data ~cmp = - match N.toOpt t with (* TODO: test case with the same key *) - None -> - N.(return @@ node ~left:empty ~key:x ~value:data ~right:empty ~h:1) +let rec update0 (t : _ t0) newK newD ~cmp = + match N.toOpt t with + | None -> N.singleton0 newK newD | Some n -> - let l,k,v,r = N.(left n, key n, value n, right n) in - let c = (Bs_Cmp.getCmp cmp) x k [@bs] in + let k= N.key n in + let c = (Bs_Cmp.getCmp cmp) newK k [@bs] in if c = 0 then - N.(return @@ node ~left:l ~key:x ~value:data ~right:r ~h:(h n)) - else if c < 0 then - N.(bal (add0 ~cmp l x data ) k v r) - else - N.(bal l k v (add0 ~cmp r x data )) - -let rec findOpt0 n x ~cmp = - match N.toOpt n with - None -> None - | Some n (* Node(l, v, d, r, _) *) -> - let v = N.key n in - let c = (Bs_Cmp.getCmp cmp) x v [@bs] in - if c = 0 then Some (N.value n) - else findOpt0 ~cmp (if c < 0 then N.left n else N.right n) x - -let rec findAssert0 n x ~cmp = - match N.toOpt n with - | None -> - [%assert "Not_found"] - | Some n (* Node(l, v, d, r, _)*) -> - let v = N.key n in - let c = (Bs_Cmp.getCmp cmp) x v [@bs] in - if c = 0 then N.value n - else findAssert0 ~cmp (if c < 0 then N.left n else N.right n) x - -let rec findWithDefault0 n x def ~cmp = - match N.toOpt n with - None -> - def - | Some n (* Node(l, v, d, r, _)*) -> - let v = N.key n in - let c = (Bs_Cmp.getCmp cmp) x v [@bs] in - if c = 0 then N.value n - else findWithDefault0 ~cmp (if c < 0 then N.left n else N.right n) x def - - -let rec mem0 x n ~cmp = - match N.toOpt n with - None -> - false - | Some n (* Node(l, v, d, r, _) *) -> - let v = N.key n in - let c = (Bs_Cmp.getCmp cmp) x v [@bs] in - c = 0 || mem0 ~cmp x (if c < 0 then N.left n else N.right n) - - -let rec remove0 n x ~cmp = - match N.toOpt n with - None -> - n - | Some n (* Node(l, v, d, r, h) *) -> + N.updateKV n newK newD + else + let l,r,v = N.left n, N.right n, N.value n in + if c < 0 then + N.bal (update0 ~cmp l newK newD ) k v r + else + N.bal l k v (update0 ~cmp r newK newD ) + +let rec updateWithOpt0 (t : _ t0) newK f ~cmp = + match N.toOpt t with + | None -> + begin match f None [@bs] with + | None -> t + | Some newD -> N.singleton0 newK newD + end + | Some n -> + let k= N.key n in + let c = (Bs_Cmp.getCmp cmp) newK k [@bs] in + if c = 0 then + match f (Some k) [@bs] with + | None -> t + | Some newD -> N.updateKV n newK newD + else + let l,r,v = N.left n, N.right n, N.value n in + if c < 0 then + N.bal (updateWithOpt0 ~cmp l newK f ) k v r + else + N.bal l k v (updateWithOpt0 ~cmp r newK f) + +(* unboxing API was not exported + since the correct API is really awkard + [bool -> 'k Js.null -> ('a Js.null * bool)] + even for specialized [k] the first [bool] can + be erased, maybe the perf boost does not justify the inclusion of such API + + [updateWithNull m x f] + the callback to [f exist v] + when [v] is non-null, + [exist] is guaranteed to be true + [v] is guranteed to be [null], + when [exist] is [true], [v] could be [null], + since ['a] is polymorphic +*) + + +let rec remove0 t x ~cmp = + match N.toOpt t with + | None -> + t + | Some n -> let l,v,r = N.(left n, key n, right n ) in let c = (Bs_Cmp.getCmp cmp) x v [@bs] in if c = 0 then @@ -108,206 +89,203 @@ let rec remove0 n x ~cmp = let r = N.removeMinAuxWithRef rn kr vr in N.bal l !kr !vr r else if c < 0 then - N.(bal (remove0 ~cmp l x ) v (value n) r) + let ll = remove0 l x ~cmp in + if ll == l then t + else N.bal ll v (N.value n) r else - N.(bal l v (value n) (remove0 ~cmp r x )) + let rr = remove0 ~cmp r x in + if rr == r then t + else N.bal l v (N.value n) rr -let rec splitAux ~cmp x (n : _ N.node) : _ t0 * _ option * _ t0 = +let rec splitAuxPivot ~cmp n x pres = let l,v,d,r = N.(left n , key n, value n, right n) in let c = (Bs_Cmp.getCmp cmp) x v [@bs] in - if c = 0 then (l, Some d, r) + if c = 0 then begin + pres := Some d; + (l, r) + end else if c < 0 then match N.toOpt l with | None -> - N.(empty , None, return n) + N.(empty, return n) | Some l -> - let (ll, pres, rl) = splitAux ~cmp x l in (ll, pres, N.join rl v d r) + let (ll,rl) = splitAuxPivot ~cmp l x pres in + (ll, N.join rl v d r) else match N.toOpt r with | None -> - N.(return n, None, empty) + N.(return n, empty) | Some r -> - let (lr, pres, rr) = splitAux ~cmp x r in (N.join l v d lr, pres, rr) + let (lr, rr) = splitAuxPivot ~cmp r x pres in + (N.join l v d lr, rr) -let split0 ~cmp x n = +let split0 ~cmp n x = match N.toOpt n with | None -> - N.(empty, None, empty) - | Some n (* Node(l, v, d, r, _) *) -> - splitAux ~cmp x n + N.(empty, empty), None + | Some n -> + let pres = ref None in + let v = splitAuxPivot ~cmp n x pres in + v, !pres let rec merge0 s1 s2 f ~cmp = match N.(toOpt s1, toOpt s2) with (None, None) -> N.empty - | Some n (* (Node (l1, v1, d1, r1, h1), _) *), _ - when N.h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n) -> - let l1, v1, d1, r1 = N.(left n, key n, value n, right n) in - let (l2, d2, r2) = split0 ~cmp v1 s2 in - N.concatOrJoin (merge0 ~cmp l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge0 ~cmp r1 r2 f) - | _, Some n (* Node (l2, v2, d2, r2, h2)*) -> - let l2,v2,d2,r2 = N.(left n, key n, value n, right n) in - let (l1, d1, r1) = split0 ~cmp v2 s1 in - N.concatOrJoin (merge0 ~cmp l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge0 ~cmp r1 r2 f) - | _ -> - assert false - -let rec compareAux e1 e2 ~kcmp ~vcmp = - match e1,e2 with - | h1::t1, h2::t2 -> - let c = (Bs_Cmp.getCmp kcmp) (N.key h1) (N.key h2) [@bs] in - if c = 0 then - let cx = vcmp (N.value h1) (N.value h2) [@bs] in - if cx = 0 then - compareAux ~kcmp ~vcmp - (N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - else cx - else c - | _, _ -> 0 - -let rec eqAux e1 e2 ~kcmp ~vcmp = - match e1,e2 with - | h1::t1, h2::t2 -> - if (Bs_Cmp.getCmp kcmp) (N.key h1) (N.key h2) [@bs] = 0 && - vcmp (N.value h1) (N.value h2) [@bs] then - eqAux ~kcmp ~vcmp ( - N.stackAllLeft (N.right h1) t1 ) (N.stackAllLeft (N.right h2) t2) - else false - | _, _ -> true (*end *) - - -let cmp0 s1 s2 ~kcmp ~vcmp = - let len1,len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - compareAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) ~kcmp ~vcmp - else if len1 < len2 then -1 else 1 - -let eq0 s1 s2 ~kcmp ~vcmp = - let len1, len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - eqAux (N.stackAllLeft s1 []) (N.stackAllLeft s2 []) ~kcmp ~vcmp - else false - - -let ofArray0 ~cmp (xs : _ array) : _ t0 = - let result = ref N.empty in - for i = 0 to Array.length xs - 1 do - let k, v = (Bs_Array.unsafe_get xs i) in - result := add0 ~cmp !result k v - done ; - !result + | Some _, None -> + N.filterMap0 s1 (fun[@bs] k v -> + f k (Some v) None [@bs] + ) + | None, Some _ -> + N.filterMap0 s2 (fun[@bs] k v -> + f k None (Some v) [@bs] + ) + | Some s1n , Some s2n -> + if N.h s1n >= N.h s2n then + let l1, v1, d1, r1 = N.(left s1n, key s1n, value s1n, right s1n) in + let d2 = ref None in + let (l2, r2) = splitAuxPivot ~cmp s2n v1 d2 in + let d2 = !d2 in + let newLeft = merge0 ~cmp l1 l2 f in + let newD = f v1 (Some d1) d2 [@bs] in + let newRight = merge0 ~cmp r1 r2 f in + N.concatOrJoin newLeft v1 newD newRight + else + let l2,v2,d2,r2 = N.(left s2n, key s2n, value s2n, right s2n) in + let d1 = ref None in + let (l1, r1) = splitAuxPivot ~cmp s1n v2 d1 in + let d1 = !d1 in + let newLeft = merge0 ~cmp l1 l2 f in + let newD = (f v2 d1 (Some d2) [@bs]) in + let newRight = (merge0 ~cmp r1 r2 f) in + N.concatOrJoin newLeft v2 newD newRight + + + + let empty dict = B.bag ~dict - ~data:empty0 + ~data:N.empty0 let isEmpty map = - isEmpty0 (B.data map) + N.isEmpty0 (B.data map) let singleton dict k v = B.bag ~dict - ~data:(singleton0 k v) + ~data:(N.singleton0 k v) let iter map f = - iter0 (B.data map) f + N.iter0 (B.data map) f let fold map acc f = - fold0 (B.data map) acc f + N.fold0 (B.data map) acc f let forAll map f = - forAll0 (B.data map) f + N.forAll0 (B.data map) f let exists map f = - exists0 (B.data map) f + N.exists0 (B.data map) f let filter f map = let dict, map = B.(dict map, data map) in - B.bag ~dict ~data:(filter0 f map) + B.bag ~dict ~data:(N.filterShared0 f map) let partition p map = let dict, map = B.(dict map, data map) in - let l,r = partition0 p map in + let l,r = N.partitionShared0 p map in B.bag ~dict ~data:l, B.bag ~dict ~data:r let length map = - length0 (B.data map) + N.length0 (B.data map) let toList map = - toList0 (B.data map) + N.toList0 (B.data map) +let toArray m = + N.toArray0 (B.data m) +let keysToArray m = + N.keysToArray0 (B.data m) +let valuesToArray m = + N.valuesToArray0 (B.data m) + +let minKVOpt m = N.minKVOpt0 (B.data m) +let minKVNull m = N.minKVNull0 (B.data m) +let maxKVOpt m = N.maxKVOpt0 (B.data m) +let maxKVNull m = N.maxKVNull0 (B.data m) -let minBinding map = - minBinding0 (B.data map) -let maxBinding map = - maxBinding0 (B.data map) let map m f = let dict, map = B.(dict m, data m) in - B.bag ~dict ~data:(map0 map f) + B.bag ~dict ~data:(N.map0 map f) let mapi map f = let dict,map = B.(dict map, data map) in - B.bag ~dict ~data:(mapi0 map f) + B.bag ~dict ~data:(N.mapi0 map f) -let add (type k) (type v) (type id) (map : (k,v,id) t) key data = +let update (type k) (type id) (map : (k,_,id) t) key data = let dict,map = B.(dict map, data map) in let module X = (val dict) in - B.bag ~dict ~data:(add0 ~cmp:X.cmp map key data ) - + B.bag ~dict ~data:(update0 ~cmp:X.cmp map key data ) -let ofArray (type k) (type v) (type id) (dict : (k,id) Bs_Cmp.t) data = +let updateWithOpt (type k) (type id) (map : (k,_,id) t) key f = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + B.bag ~dict ~data:(updateWithOpt0 ~cmp:X.cmp map key f ) + +let ofArray (type k) (type id) (dict : (k,id) Bs_Cmp.t) data = let module M = (val dict ) in B.bag ~dict - ~data:(ofArray0 ~cmp:M.cmp data) + ~data:(N.ofArray0 ~cmp:M.cmp data) - -let findOpt (type k) (type v) (type id) (map : (k,v,id) t) x = +let findOpt (type k) (type id) (map : (k,_,id) t) x = let dict,map = B.(dict map, data map) in let module X = (val dict) in - findOpt0 ~cmp:X.cmp map x + N.findOpt0 ~cmp:X.cmp map x -let findAssert (type k) (type v) (type id) (map : (k,v,id) t) x = +let findNull (type k) (type id) (map : (k,_,id) t) x = let dict,map = B.(dict map, data map) in let module X = (val dict) in - findAssert0 ~cmp:X.cmp map x + N.findNull0 ~cmp:X.cmp map x -let findWithDefault (type k) (type v) (type id) (map : (k,v,id) t) x def = +let findWithDefault (type k) (type id) (map : (k,_,id) t) x def = let dict,map = B.(dict map, data map) in let module X = (val dict) in - findWithDefault0 ~cmp:X.cmp map x def - + N.findWithDefault0 ~cmp:X.cmp map x def -let mem (type k) (type v) (type id) (map : (k,v,id) t) x = +let findExn (type k) (type id) (map : (k,_,id) t) x = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.findExn0 ~cmp:X.cmp map x + +let mem (type k) (type id) (map : (k,_,id) t) x = let dict,map = B.(dict map, data map) in let module X = (val dict) in - mem0 ~cmp:X.cmp x map + N.mem0 ~cmp:X.cmp map x -let remove (type k) (type v) (type id) (map : (k,v,id) t) x = +let remove (type k) (type id) (map : (k,_,id) t) x = let dict,map = B.(dict map, data map) in let module X = (val dict) in B.bag ~dict ~data:(remove0 ~cmp:X.cmp map x ) -let split (type k) (type v) (type id) x (map : (k,v,id) t) = +let split (type k) (type id) (map : (k,_,id) t) x = let dict,map = B.(dict map, data map) in - let module X = (val dict) in - let l,v,r = split0 ~cmp:X.cmp x map in - B.bag ~dict - ~data:l - , - v , - B.bag ~dict - ~data:r + let (l,r),v = split0 ~cmp:X.cmp map x in + (B.bag ~dict + ~data:l + , + B.bag ~dict + ~data:r), v -let merge (type k) (type v) (type id) (s1 : (k,v,id) t) +let merge (type k) (type id) (s1 : (k,_,id) t) (s2 : (k,_,id) t) f = let dict, s1_data, s2_data = B.(dict s1, data s1, data s2) in let module X = (val dict) in @@ -315,16 +293,44 @@ let merge (type k) (type v) (type id) (s1 : (k,v,id) t) ~dict -let cmp (type k) (type v) (type id) - (m1 : (k,v,id) t) (m2 : (k,v,id) t) +let cmp (type k) (type id) + (m1 : (k,'v,id) t) (m2 : (k,'v,id) t) cmp = let dict, m1_data, m2_data = B.(dict m1, data m1, data m2) in let module X = (val dict) in - cmp0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data + N.cmp0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data -let eq (type k) (type v) (type id) - (m1 : (k,v,id) t) (m2 : (k,v,id) t) cmp = +let eq (type k) (type id) + (m1 : (k,'v,id) t) (m2 : (k,'v,id) t) cmp = let dict, m1_data, m2_data = B.(dict m1, data m1, data m2) in let module X = (val dict) in - eq0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data \ No newline at end of file + N.eq0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data + +let empty0 = N.empty0 +let isEmpty0 = N.isEmpty0 +let singleton0 = N.singleton0 +let minKVOpt0 = N.minKVOpt0 +let maxKVOpt0 = N.maxKVOpt0 +let iter0 = N.iter0 +let map0 = N.map0 +let mapi0 = N.mapi0 +let fold0 = N.fold0 +let forAll0 = N.forAll0 +let exists0 = N.exists0 + + +let length0 = N.length0 +let toList0 = N.toList0 +let ofArray0 = N.ofArray0 +let findOpt0 = N.findOpt0 +let findNull0 = N.findNull0 +let findWithDefault0 = N.findWithDefault0 +let findExn0 = N.findExn0 +let mem0 = N.mem0 +let cmp0 = N.cmp0 +let eq0 = N.eq0 +let keysToArray0 = N.keysToArray0 +let valuesToArray0 = N.valuesToArray0 +let filter0 = N.filterShared0 +let partition0 = N.partitionShared0 \ No newline at end of file diff --git a/jscomp/others/bs_Map.mli b/jscomp/others/bs_Map.mli index 503bcce51a7..20bef54152e 100644 --- a/jscomp/others/bs_Map.mli +++ b/jscomp/others/bs_Map.mli @@ -11,9 +11,9 @@ (* *) (***********************************************************************) (** Adapted by authors of BuckleScript without using functors *) -(** The type of the map keys. *) + type ('k, 'a, 'id) t0 -(** [('k, 'a, id) t] +(** ['k] the key type ['a] the value type ['id] is a unique type for each keyed module @@ -23,6 +23,7 @@ type ('k, 'a, 'id) t0 type ('k,'v,'id) t = (('k,'id) Bs_Cmp.t, ('k,'v, 'id) t0 ) Bs_Bag.bag +(** The data associated with a comparison function *) (* How we remain soundness: @@ -58,11 +59,18 @@ val ofArray: val isEmpty: ('k, 'a, 'id) t -> bool val mem: ('k, 'a, 'id) t -> 'k -> bool -val add: ('k, 'a, 'id) t -> 'k -> 'a -> ('k, 'a, 'id) t -(** [add m x y ] returns a map containing the same bindings as - [m], plus a binding of [x] to [y]. If [x] was already bound + +val update: ('k, 'a, 'id) t -> 'k -> 'a -> ('k, 'a, 'id) t +(** [update m x y ] returns a map containing the same bindings as + [m], with a new binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) +val updateWithOpt: + ('k, 'a, 'id) t -> + 'k -> + ('k option -> 'a option [@bs]) -> + ('k, 'a, 'id) t + val singleton: ('k,'id) Bs_Cmp.t -> 'k -> 'a -> ('k, 'a, 'id) t @@ -128,24 +136,19 @@ val length: ('k, 'a, 'id) t -> int val toList: ('k, 'a, 'id) t -> ('k * 'a) list -(** Return the list of all bindings of the given map. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Map.Make}. -*) - -val minBinding: ('k, 'a, 'id) t -> ('k * 'a) option -(** Return the smallest binding of the given map - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the map is empty. -*) - -val maxBinding: ('k, 'a, 'id) t -> ('k * 'a) option -(** Same as {!Map.S.min_binding}, but returns the largest binding - of the given map. -*) - -val split: 'k -> ('k, 'a, 'id) t -> ('k, 'a, 'id) t * 'a option * ('k, 'a, 'id) t +(** In increasing order*) +val toArray : ('k, 'a, 'id) t -> ('k * 'a) array +val keysToArray : ('k, 'a, 'id) t -> 'k array +val valuesToArray : ('k, 'a, 'id) t -> 'a array + +val minKVOpt: ('k, 'a, _) t -> ('k * 'a) option +val minKVNull: ('k, 'a, _) t -> ('k * 'a) Js.null +val maxKVOpt: ('k, 'a, _) t -> ('k * 'a) option +val maxKVNull:('k, 'a, _) t -> ('k * 'a) Js.null + +val split: + ('k, 'a, 'id) t -> 'k -> + (('k, 'a, 'id) t * ('k, 'a, 'id) t )* 'a option (** [split x m] returns a triple [(l, data, r)], where [l] is the map with all the bindings of [m] whose 'k is strictly less than [x]; @@ -156,13 +159,10 @@ val split: 'k -> ('k, 'a, 'id) t -> ('k, 'a, 'id) t * 'a option * ('k, 'a, 'id) *) val findOpt: ('k, 'a, 'id) t -> 'k -> 'a option -(** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. *) -val findAssert: ('k, 'a, 'id) t -> 'k -> 'a - +val findNull: ('k, 'a, 'id) t -> 'k -> 'a Js.null val findWithDefault: ('k, 'a, 'id) t -> 'k -> 'a -> 'a - +val findExn: ('k, 'a, 'id) t -> 'k -> 'a val map: ('k, 'a, 'id) t -> ('a -> 'b [@bs]) -> ('k ,'b,'id ) t (** [map m f] returns a map with same domain as [m], where the associated value [a] of all bindings of [m] has been @@ -181,14 +181,15 @@ val ofArray0: val isEmpty0 : ('k, 'a,'id) t0 -> bool val mem0: - 'k -> ('k, 'a, 'id) t0 -> + 'k -> cmp: ('k,'id) Bs_Cmp.cmp -> bool -val add0: - ('k, 'a, 'id) t0 -> - 'k -> 'a -> +val update0: + ('k, 'a, 'id) t0 -> + 'k -> + 'a -> cmp: ('k,'id) Bs_Cmp.cmp -> ('k, 'a, 'id) t0 @@ -236,16 +237,18 @@ val length0: ('k, 'a, 'id) t0 -> int val toList0: ('k, 'a, 'id) t0 -> ('k * 'a) list -val minBinding0: ('k, 'a, 'id) t0 -> ('k * 'a) option +val minKVOpt0: ('k, 'a, 'id) t0 -> ('k * 'a) option -val maxBinding0: ('k, 'a, 'id) t0 -> ('k * 'a) option +val maxKVOpt0: ('k, 'a, 'id) t0 -> ('k * 'a) option val split0: cmp: ('k,'id) Bs_Cmp.cmp -> - 'k -> ('k, 'a, 'id) t0 -> ('k, 'a, 'id) t0 * 'a option * ('k, 'a, 'id) t0 + ('k, 'a, 'id) t0 -> + 'k -> + (('k, 'a, 'id) t0 * ('k, 'a, 'id) t0) * 'a option @@ -254,20 +257,22 @@ val findOpt0: 'k -> cmp: ('k,'id) Bs_Cmp.cmp -> 'a option - -val findAssert0: +val findNull0: ('k, 'a, 'id) t0 -> 'k -> cmp: ('k,'id) Bs_Cmp.cmp -> - 'a - - + 'a Js.null val findWithDefault0: ('k, 'a, 'id) t0 -> 'k -> 'a -> cmp: ('k,'id) Bs_Cmp.cmp -> 'a +val findExn0: + ('k, 'a, 'id) t0 -> + 'k -> + cmp: ('k,'id) Bs_Cmp.cmp -> + 'a val map0: ('k, 'a, 'id) t0 -> ('a -> 'b [@bs]) -> ('k ,'b,'id ) t0 diff --git a/jscomp/others/bs_MapInt.ml b/jscomp/others/bs_MapInt.ml index 17dfaeb175a..7a9a18a47b0 100644 --- a/jscomp/others/bs_MapInt.ml +++ b/jscomp/others/bs_MapInt.ml @@ -1,78 +1,69 @@ -# 4 "map.cppo.ml" +# 5 "map.cppo.ml" type key = int +module I = Bs_internalMapInt -# 9 +# 11 module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort -type ('key, 'a, 'id) t0 = ('key,'a) N.t0 - -type 'a t = (key,'a) N.t0 - - - - +type 'a t = (key, 'a) N.t0 let empty = N.empty0 let isEmpty = N.isEmpty0 let singleton = N.singleton0 -let minBinding = N.minKVOpt0 -let maxBinding = N.maxKVOpt0 +let minKVOpt = N.minKVOpt0 +let minKVNull = N.minKVNull0 +let maxKVOpt = N.maxKVOpt0 +let maxKVNull = N.maxKVNull0 let iter = N.iter0 let map = N.map0 let mapi = N.mapi0 let fold = N.fold0 let forAll = N.forAll0 let exists = N.exists0 -let filter = N.filter0 -let partition = N.partition0 +let filter = N.filterShared0 +let partition = N.partitionShared0 let length = N.length0 let toList = N.toList0 let checkInvariant = N.checkInvariant -let rec add t (x : key) (data : _) = +let rec update t (newK : key) (newD : _) = match N.toOpt t with | None -> - N.(return @@ node ~left:empty ~key:x ~value:data ~right:empty ~h:1) - | Some n (* Node(l, v, d, r, h) *) -> - let l,k,v,r = N.(left n, key n, value n, right n) in - if x = k then - N.(return @@ node ~left:l ~key:x ~value:data ~right:r ~h:(h n)) - else if x < k then - N.(bal (add l x data ) k v r) - else - N.(bal l k v (add r x data )) - -let rec findOpt (x : key) n = - match N.toOpt n with - None -> None + N.singleton0 newK newD | Some n -> - let v = N.key n in - if x = v then Some (N.value n) - else findOpt x (if x < v then N.left n else N.right n) - -let rec findAssert (x : key) n = - match N.toOpt n with - | None -> - [%assert "Not_found"] + let k = N.key n in + if newK = k then + N.updateKV n newK newD + else + let v = N.value n in + if newK < k then + N.bal (update (N.left n) newK newD) k v (N.right n) + else + N.bal (N.left n) k v (update (N.right n) newK newD) + +let rec updateWithOpt t (x : key) f = + match N.toOpt t with + | None -> + begin match f None [@bs] with + | None -> t + | Some data -> + N.singleton0 x data + end | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findAssert x (if x < v then (N.left n) else (N.right n)) - -let rec findWithDefault n (x : key) def = - match N.toOpt n with - | None -> def - | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findWithDefault (if x < v then (N.left n) else (N.right n)) x def - -let rec mem n (x : key)= - match N.toOpt n with - None -> false - | Some n (* Node(l, v, d, r, _) *) -> - let v = N.key n in - x = v || mem (if x < v then N.left n else N.right n) x + let k = N.key n in + if x = k then + begin match f (Some k) [@bs] with + | None -> t + | Some data -> N.updateKV n x data + end + else + let v = N.value n in + if x < k then + N.bal (updateWithOpt (N.left n) x f) k v (N.right n) + else + N.bal (N.left n) k v (updateWithOpt (N.right n) x f) let rec remove n (x : key) = match N.toOpt n with @@ -92,100 +83,13 @@ let rec remove n (x : key) = else N.(bal l v (value n) (remove r x )) -let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = - let l,v,d,r = N.(left n , key n, value n, right n) in - if x = v then (l, Some d, r) - else - if x < v then - match N.toOpt l with - | None -> - N.(empty , None, return n) - | Some l -> - let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) - else - match N.toOpt r with - | None -> - N.(return n, None, empty) - | Some r -> - let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) - - -let rec split (x : key) n = - match N.toOpt n with - None -> - N.(empty, None, empty) - | Some n -> - splitAux x n - -let rec merge s1 s2 f = - match N.(toOpt s1, toOpt s2) with - (None, None) -> N.empty - | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ - when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> - let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in - let (l2, d2, r2) = split v1 s2 in - N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) - | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> - let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in - let (l1, d1, r1) = split v2 s1 in - N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) - | _ -> - assert false - -let rec compareAux e1 e2 vcmp = - match e1,e2 with - | h1::t1, h2::t2 -> - let c = Pervasives.compare (N.key h1 : key) (N.key h2) in - if c = 0 then - let cx = vcmp (N.value h1) (N.value h2) [@bs] in - if cx = 0 then - compareAux - (N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - vcmp - else cx - else c - | _, _ -> 0 - -let cmp s1 s2 cmp = - let len1, len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - compareAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) - cmp - else if len1 < len2 then -1 - else 1 - - -let rec eqAux e1 e2 eq = - match e1,e2 with - | h1::t1, h2::t2 -> - if (N.key h1 : key) = (N.key h2) && - eq (N.value h1) (N.value h2) [@bs] then - eqAux ( - N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - eq - else false - | _, _ -> true (*end *) - -let eq s1 s2 eq = - let len1,len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - eqAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) eq - else false - -let ofArray (xs : _ array) : _ t0 = - let result = ref N.empty in - for i = 0 to Array.length xs - 1 do - let k, v = (Bs_Array.unsafe_get xs i) in - result := add !result k v - done ; - !result - - - - +let mem = I.mem +let cmp = I.cmp +let eq = I.eq +let findOpt = I.findOpt +let findNull = I.findNull +let findWithDefault = I.findWithDefault +let findExn = I.findExn +let split = I.split +let merge = I.merge +let ofArray = I.ofArray \ No newline at end of file diff --git a/jscomp/others/bs_MapInt.mli b/jscomp/others/bs_MapInt.mli index a5f75b0bda2..4aec10827c7 100644 --- a/jscomp/others/bs_MapInt.mli +++ b/jscomp/others/bs_MapInt.mli @@ -5,19 +5,22 @@ type 'a t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t -(** The empty map. *) val ofArray: (key * 'a) array -> 'a t val isEmpty: 'a t -> bool -(** Test whether a map is empty or not. *) val mem: 'a t -> key -> bool -val add: 'a t -> key -> 'a -> 'a t +val update: 'a t -> key -> 'a -> 'a t (** [add m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) +val updateWithOpt: + 'a t -> + key -> + (key option -> 'a option [@bs]) -> + 'a t val singleton: key -> 'a -> 'a t @@ -85,14 +88,11 @@ val toList: 'a t -> (key * 'a) list given to {!Map.Make}. *) -val minBinding: 'a t -> (key * 'a) option -(** Return the smallest binding of the given map - or raise - *) +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null -val maxBinding: 'a t -> (key * 'a) option -(** returns the largest binding of the given map. - *) @@ -106,13 +106,10 @@ val split: key -> 'a t -> 'a t * 'a option * 'a t or [Some v] if [m] binds [v] to [x]. *) -val findOpt: key -> 'a t -> 'a option -(** [findOpt x m] returns the current binding of [x] in [m] *) - -val findAssert: key -> 'a t -> 'a -(** raise an exception if not there *) - +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn: 'a t -> key -> 'a val map: 'a t -> ('a -> 'b [@bs]) -> 'b t (** [map m f] returns a map with same domain as [m], where the diff --git a/jscomp/others/bs_MapIntM.ml b/jscomp/others/bs_MapIntM.ml new file mode 100644 index 00000000000..d93aaae60ab --- /dev/null +++ b/jscomp/others/bs_MapIntM.ml @@ -0,0 +1,108 @@ +# 2 "mapm.cppo.ml" +module I = Bs_internalMapInt +module S = Bs_SortInt +type key = int +# 12 +module N = Bs_internalAVLtree +module A = Bs_Array + + + + +type 'a t = { + mutable data : 'a I.t +} [@@bs.deriving abstract] + + +let empty () = t ~data:N.empty0 +let isEmpty m = N.isEmpty0 (data m) +let singleton k v = t ~data:(N.singleton0 k v) +let minKVOpt m = N.minKVOpt0 (data m) +let minKVNull m = N.minKVNull0 (data m) +let maxKVOpt m = N.maxKVOpt0 (data m) +let maxKVNull m = N.maxKVNull0 (data m) + +let addOnly (m : _ t) k v = + let old_data = data m in + let v = I.addMutate old_data k v in + if v != old_data then + dataSet m v + +let add (d : 'a t) (k : key) (v : 'a) : 'a t= + addOnly d k v; + d +let iter d f = N.iter0 (data d) f +let map d f = t ~data:(N.map0 (data d) f) +let mapi d f = t ~data:(N.mapi0 (data d) f) +let fold d acc f = N.fold0 (data d) acc f +let forAll d f = N.forAll0 (data d) f +let exists d f = N.exists0 (data d) f + +let length d = N.length0 (data d) +let toList d = N.toList0 (data d) +let checkInvariant d = N.checkInvariant (data d) +let mem d v = I.mem (data d) v + + +let rec removeMutateAux nt (x : key)= + let k = N.key nt in + if x = k then + let l,r = N.(left nt, right nt) in + match N.(toOpt l, toOpt r) with + | Some _, Some nr -> + N.rightSet nt (N.removeMinAuxWithRootMutate nt nr); + N.return (N.balMutate nt) + | None, Some _ -> + r + | (Some _ | None ), None -> l + else + begin + if x < k then + match N.toOpt (N.left nt) with + | None -> N.return nt + | Some l -> + N.leftSet nt (removeMutateAux l x ); + N.return (N.balMutate nt) + else + match N.toOpt (N.right nt) with + | None -> N.return nt + | Some r -> + N.rightSet nt (removeMutateAux r x); + N.return (N.balMutate nt) + end +let removeMutate nt x = + match N.toOpt nt with + | None -> nt + | Some nt -> removeMutateAux nt x + +let removeOnly d v = + let old_data = data d in + let v = removeMutate old_data v in + if v != old_data then + dataSet d v + +let remove d v = + removeOnly d v; + d + + +let cmp = I.cmp +let eq = I.eq + + +(* let split = I.split *) +(* let merge = I.merge *) + + +let ofArray xs = + t ~data:(I.ofArray xs) + +let cmp d0 d1 = + I.cmp (data d0) (data d1) +let eq d0 d1 = + I.eq (data d0) (data d1) +let findOpt d x = + I.findOpt (data d) x +let findNull d x = I.findNull (data d) x +let findWithDefault d x def = I.findWithDefault (data d) x def +let findExn d x = I.findExn (data d) x \ No newline at end of file diff --git a/jscomp/others/bs_MapIntM.mli b/jscomp/others/bs_MapIntM.mli new file mode 100644 index 00000000000..ab5c9afeb32 --- /dev/null +++ b/jscomp/others/bs_MapIntM.mli @@ -0,0 +1,120 @@ +# 4 "mapm.cppo.mli" +type key = int +# 8 +type 'a t + + +val empty: unit -> 'a t + +val ofArray: (key * 'a) array -> 'a t + +val isEmpty: 'a t -> bool + +val mem: 'a t -> key -> bool + +val addOnly : 'a t -> key -> 'a -> unit +val add: 'a t -> key -> 'a -> 'a t +(** [add m x y] do the in-place modification, return + [m] for chaining. If [x] was already bound + in [m], its previous binding disappears. *) + +val singleton: key -> 'a -> 'a t + +val remove: 'a t -> key -> 'a t +(** [remove m x] do the in-place modification, return [m] for chaining *) + +(* val merge: + 'a t -> 'b t -> + (key -> 'a option -> 'b option -> 'c option [@bs]) -> + 'c t *) +(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + *) + +val cmp: 'a t -> 'a t -> ('a -> 'a -> int [@bs]) -> int + +val eq: 'a t -> 'a t -> ('a -> 'a -> bool [@bs]) -> bool +(** [equal m1 m2 cmp] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + +val iter: 'a t -> (key -> 'a -> unit [@bs]) -> unit +(** [iter m f] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + +val fold: 'a t -> 'b -> ('b -> key -> 'a -> 'b [@bs]) -> 'b +(** [fold m a f] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val forAll: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [forAll m p] checks if all the bindings of the map + satisfy the predicate [p]. + *) + +val exists: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [exists m p] checks if at least one binding of the map + satisfy the predicate [p]. + *) + +(* val filter: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t *) +(** [filter m p] returns the map with all the bindings in [m] + that satisfy predicate [p]. +*) + + +(* val partition: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t * 'a t *) +(** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + *) + +val length: 'a t -> int + + +val toList: 'a t -> (key * 'a) list +(** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + *) + +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null + + + + +(* val split: key -> 'a t -> 'a t * 'a option * 'a t *) +(** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + *) + +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null +val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn : 'a t -> key -> 'a + +val map: 'a t -> ('a -> 'b [@bs]) -> 'b t +(** [map m f] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: 'a t -> (key -> 'a -> 'b [@bs]) -> 'b t + + +val checkInvariant : _ t -> bool diff --git a/jscomp/others/bs_MapM.ml b/jscomp/others/bs_MapM.ml new file mode 100644 index 00000000000..34d3fec12bb --- /dev/null +++ b/jscomp/others/bs_MapM.ml @@ -0,0 +1,168 @@ + +(* Copyright (C) 2017 Authors of BuckleScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + +module N = Bs_internalAVLtree +module B = Bs_BagM +module A = Bs_Array + +type ('k, 'v, 'id) t = + (('k,'id) Bs_Cmp.t, ('k,'v) N.t0 ) B.bag + +let rec removeMutateAux ~cmp nt x = + let k = N.key nt in + let c = (Bs_Cmp.getCmp cmp) x k [@bs] in + if c = 0 then + let l,r = N.(left nt, right nt) in + match N.(toOpt l, toOpt r) with + | Some _, Some nr -> + N.rightSet nt (N.removeMinAuxWithRootMutate nt nr); + N.return (N.balMutate nt) + | None, Some _ -> + r + | (Some _ | None ), None -> l + else + begin + if c < 0 then + match N.toOpt (N.left nt) with + | None -> N.return nt + | Some l -> + N.leftSet nt (removeMutateAux ~cmp l x ); + N.return (N.balMutate nt) + else + match N.toOpt (N.right nt) with + | None -> N.return nt + | Some r -> + N.rightSet nt (removeMutateAux ~cmp r x); + N.return (N.balMutate nt) + end + +let removeOnly (type elt) (type id) (d : (elt,_,id) t) k = + let dict, oldRoot = B.(dict d, data d) in + let module M = (val dict) in + match N.toOpt oldRoot with + | None -> () + | Some oldRoot2 -> + let newRoot = removeMutateAux ~cmp:M.cmp oldRoot2 k in + if newRoot != oldRoot then + B.dataSet d newRoot +let remove d v = + removeOnly d v; + d +let empty dict = + B.bag ~dict ~data:N.empty0 +let isEmpty d = + N.isEmpty0 (B.data d) +let singleton dict x v= + B.bag ~data:(N.singleton0 x v) ~dict + +let minKVOpt m = N.minKVOpt0 (B.data m) +let minKVNull m = N.minKVNull0 (B.data m) +let maxKVOpt m = N.maxKVOpt0 (B.data m) +let maxKVNull m = N.maxKVNull0 (B.data m) + +let iter d f = + N.iter0 (B.data d) f +let fold d acc cb = + N.fold0 (B.data d) acc cb +let forAll d p = + N.forAll0 (B.data d) p +let exists d p = + N.exists0 (B.data d) p + +let length d = + N.length0 (B.data d) +let toList d = + N.toList0 (B.data d) +let toArray d = + N.toArray0 (B.data d) +let ofSortedArrayUnsafe ~dict xs : _ t = + B.bag ~data:(N.ofSortedArrayUnsafe0 xs) ~dict +let checkInvariant d = + N.checkInvariant (B.data d) + +let addOnly (type elt) (type id) (m : (elt,_,id) t) e v = + let dict, oldRoot = B.(dict m, data m) in + let module M = (val dict) in + let newRoot = N.addMutate ~cmp:M.cmp oldRoot e v in + if newRoot != oldRoot then + B.dataSet m newRoot + +let add m e v = + addOnly m e v; + m + +let ofArray (type k) (type id) (dict : (k,id) Bs_Cmp.t) data = + let module M = (val dict ) in + B.bag + ~dict + ~data:(N.ofArray0 ~cmp:M.cmp data) + +let cmp (type k) (type id) + (m1 : (k,'v,id) t) (m2 : (k,'v,id) t) + cmp + = + let dict, m1_data, m2_data = B.(dict m1, data m1, data m2) in + let module X = (val dict) in + N.cmp0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data + +let eq (type k) (type id) + (m1 : (k,'v,id) t) (m2 : (k,'v,id) t) cmp = + let dict, m1_data, m2_data = B.(dict m1, data m1, data m2) in + let module X = (val dict) in + N.eq0 ~kcmp:X.cmp ~vcmp:cmp m1_data m2_data + +let map m f = + let dict, map = B.(dict m, data m) in + B.bag ~dict ~data:(N.map0 map f) + +let mapi map f = + let dict,map = B.(dict map, data map) in + B.bag ~dict ~data:(N.mapi0 map f) + +let findOpt (type k) (type id) (map : (k,_,id) t) x = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.findOpt0 ~cmp:X.cmp map x + +let findNull (type k) (type id) (map : (k,_,id) t) x = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.findNull0 ~cmp:X.cmp map x + +let findWithDefault (type k) (type id) (map : (k,_,id) t) x def = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.findWithDefault0 ~cmp:X.cmp map x def + +let findExn (type k) (type id) (map : (k,_,id) t) x = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.findExn0 ~cmp:X.cmp map x + +let mem (type k) (type id) (map : (k,_,id) t) x = + let dict,map = B.(dict map, data map) in + let module X = (val dict) in + N.mem0 ~cmp:X.cmp map x \ No newline at end of file diff --git a/jscomp/others/bs_MapM.mli b/jscomp/others/bs_MapM.mli new file mode 100644 index 00000000000..3e5b55fc2d5 --- /dev/null +++ b/jscomp/others/bs_MapM.mli @@ -0,0 +1,141 @@ + +(* Copyright (C) 2017 Authors of BuckleScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type ('k,'v,'id) t + +val empty: ('k, 'id) Bs_Cmp.t -> ('k, 'a, 'id) t + +val ofArray: + ('k,'id) Bs_Cmp.t -> + ('k * 'a) array -> + ('k,'a,'id) t + +val isEmpty: ('k, 'a, 'id) t -> bool +val mem: + ('k, 'a, 'id) t -> 'k -> bool + +val add: ('k, 'a, 'id) t -> 'k -> 'a -> ('k, 'a, 'id) t +(** [add m x y ] do the in-place modification, + returnning [m] for chaining. *) + +val singleton: ('k,'id) Bs_Cmp.t -> + 'k -> 'a -> ('k, 'a, 'id) t + +val remove: ('k, 'a, 'id) t -> 'k -> ('k, 'a, 'id) t +(** [remove m x] do the in-place modification, + returnning [m] for chaining. *) + + +(* val merge: *) +(* ('k, 'a, 'id ) t -> ('k, 'b,'id) t -> ('k -> 'a option -> 'b option -> 'c option [@bs]) -> ('k, 'c,'id) t *) +(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. +*) + +val cmp: + ('k, 'a, 'id) t -> + ('k, 'a, 'id) t -> + ('a -> 'a -> int [@bs]) -> + int + + +val eq: ('k, 'a, 'id) t -> ('k, 'a, 'id) t -> ('a -> 'a -> bool [@bs]) -> bool +(** [eq m1 m2 cmp] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + +val iter: ('k, 'a, 'id) t -> ('k -> 'a -> unit [@bs]) -> unit +(** [iter m f] applies [f] to all bindings in map [m]. + [f] receives the 'k as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + +val fold: ('k, 'a, 'id) t -> 'b -> ('b -> 'k -> 'a -> 'b [@bs]) -> 'b +(** [fold m a f] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val forAll: ('k, 'a, 'id) t -> ('k -> 'a -> bool [@bs]) -> bool +(** [forAll m p] checks if all the bindings of the map + satisfy the predicate [p]. +*) + + +val exists: ('k, 'a, 'id) t -> ('k -> 'a -> bool [@bs]) -> bool +(** [exists m p] checks if at least one binding of the map + satisfy the predicate [p]. +*) + +(* val filter: ('k -> 'a -> bool [@bs]) -> ('k, 'a, 'id) t -> ('k, 'a, 'id) t *) +(** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. +*) + +(* val partition: ('k -> 'a -> bool [@bs]) -> ('k, 'a, 'id) t -> ('k, 'a, 'id) t * ('k, 'a, 'id) t *) +(** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. +*) + +val length: ('k, 'a, 'id) t -> int + + +val toList: ('k, 'a, 'id) t -> ('k * 'a) list +(** In increasing order*) +val toArray : ('k, 'a, 'id) t -> ('k * 'a) array + +val minKVOpt: ('k, 'a, _) t -> ('k * 'a) option +val minKVNull: ('k, 'a, _) t -> ('k * 'a) Js.null +val maxKVOpt: ('k, 'a, _) t -> ('k * 'a) option +val maxKVNull:('k, 'a, _) t -> ('k * 'a) Js.null + +(* val split: 'k -> ('k, 'a, 'id) t -> ('k, 'a, 'id) t * 'a option * ('k, 'a, 'id) t *) +(** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose 'k + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose 'k + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. +*) + +val findOpt: ('k, 'a, 'id) t -> 'k -> 'a option +val findNull: ('k, 'a, 'id) t -> 'k -> 'a Js.null +val findWithDefault: + ('k, 'a, 'id) t -> 'k -> 'a -> 'a +val findExn: ('k, 'a, 'id) t -> 'k -> 'a +val map: ('k, 'a, 'id) t -> ('a -> 'b [@bs]) -> ('k ,'b,'id ) t +(** [map m f] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: ('k, 'a, 'id) t -> ('k -> 'a -> 'b [@bs]) -> ('k, 'b, 'id) t + + diff --git a/jscomp/others/bs_MapString.ml b/jscomp/others/bs_MapString.ml index b5d8d272acc..c1941da38e3 100644 --- a/jscomp/others/bs_MapString.ml +++ b/jscomp/others/bs_MapString.ml @@ -1,78 +1,69 @@ # 2 "map.cppo.ml" type key = string +module I = Bs_internalMapString -# 9 +# 11 module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort -type ('key, 'a, 'id) t0 = ('key,'a) N.t0 - -type 'a t = (key,'a) N.t0 - - - - +type 'a t = (key, 'a) N.t0 let empty = N.empty0 let isEmpty = N.isEmpty0 let singleton = N.singleton0 -let minBinding = N.minKVOpt0 -let maxBinding = N.maxKVOpt0 +let minKVOpt = N.minKVOpt0 +let minKVNull = N.minKVNull0 +let maxKVOpt = N.maxKVOpt0 +let maxKVNull = N.maxKVNull0 let iter = N.iter0 let map = N.map0 let mapi = N.mapi0 let fold = N.fold0 let forAll = N.forAll0 let exists = N.exists0 -let filter = N.filter0 -let partition = N.partition0 +let filter = N.filterShared0 +let partition = N.partitionShared0 let length = N.length0 let toList = N.toList0 let checkInvariant = N.checkInvariant -let rec add t (x : key) (data : _) = +let rec update t (newK : key) (newD : _) = match N.toOpt t with | None -> - N.(return @@ node ~left:empty ~key:x ~value:data ~right:empty ~h:1) - | Some n (* Node(l, v, d, r, h) *) -> - let l,k,v,r = N.(left n, key n, value n, right n) in - if x = k then - N.(return @@ node ~left:l ~key:x ~value:data ~right:r ~h:(h n)) - else if x < k then - N.(bal (add l x data ) k v r) - else - N.(bal l k v (add r x data )) - -let rec findOpt (x : key) n = - match N.toOpt n with - None -> None + N.singleton0 newK newD | Some n -> - let v = N.key n in - if x = v then Some (N.value n) - else findOpt x (if x < v then N.left n else N.right n) - -let rec findAssert (x : key) n = - match N.toOpt n with - | None -> - [%assert "Not_found"] + let k = N.key n in + if newK = k then + N.updateKV n newK newD + else + let v = N.value n in + if newK < k then + N.bal (update (N.left n) newK newD) k v (N.right n) + else + N.bal (N.left n) k v (update (N.right n) newK newD) + +let rec updateWithOpt t (x : key) f = + match N.toOpt t with + | None -> + begin match f None [@bs] with + | None -> t + | Some data -> + N.singleton0 x data + end | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findAssert x (if x < v then (N.left n) else (N.right n)) - -let rec findWithDefault n (x : key) def = - match N.toOpt n with - | None -> def - | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findWithDefault (if x < v then (N.left n) else (N.right n)) x def - -let rec mem n (x : key)= - match N.toOpt n with - None -> false - | Some n (* Node(l, v, d, r, _) *) -> - let v = N.key n in - x = v || mem (if x < v then N.left n else N.right n) x + let k = N.key n in + if x = k then + begin match f (Some k) [@bs] with + | None -> t + | Some data -> N.updateKV n x data + end + else + let v = N.value n in + if x < k then + N.bal (updateWithOpt (N.left n) x f) k v (N.right n) + else + N.bal (N.left n) k v (updateWithOpt (N.right n) x f) let rec remove n (x : key) = match N.toOpt n with @@ -92,100 +83,13 @@ let rec remove n (x : key) = else N.(bal l v (value n) (remove r x )) -let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = - let l,v,d,r = N.(left n , key n, value n, right n) in - if x = v then (l, Some d, r) - else - if x < v then - match N.toOpt l with - | None -> - N.(empty , None, return n) - | Some l -> - let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) - else - match N.toOpt r with - | None -> - N.(return n, None, empty) - | Some r -> - let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) - - -let rec split (x : key) n = - match N.toOpt n with - None -> - N.(empty, None, empty) - | Some n -> - splitAux x n - -let rec merge s1 s2 f = - match N.(toOpt s1, toOpt s2) with - (None, None) -> N.empty - | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ - when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> - let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in - let (l2, d2, r2) = split v1 s2 in - N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) - | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> - let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in - let (l1, d1, r1) = split v2 s1 in - N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) - | _ -> - assert false - -let rec compareAux e1 e2 vcmp = - match e1,e2 with - | h1::t1, h2::t2 -> - let c = Pervasives.compare (N.key h1 : key) (N.key h2) in - if c = 0 then - let cx = vcmp (N.value h1) (N.value h2) [@bs] in - if cx = 0 then - compareAux - (N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - vcmp - else cx - else c - | _, _ -> 0 - -let cmp s1 s2 cmp = - let len1, len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - compareAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) - cmp - else if len1 < len2 then -1 - else 1 - - -let rec eqAux e1 e2 eq = - match e1,e2 with - | h1::t1, h2::t2 -> - if (N.key h1 : key) = (N.key h2) && - eq (N.value h1) (N.value h2) [@bs] then - eqAux ( - N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - eq - else false - | _, _ -> true (*end *) - -let eq s1 s2 eq = - let len1,len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - eqAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) eq - else false - -let ofArray (xs : _ array) : _ t0 = - let result = ref N.empty in - for i = 0 to Array.length xs - 1 do - let k, v = (Bs_Array.unsafe_get xs i) in - result := add !result k v - done ; - !result - - - - +let mem = I.mem +let cmp = I.cmp +let eq = I.eq +let findOpt = I.findOpt +let findNull = I.findNull +let findWithDefault = I.findWithDefault +let findExn = I.findExn +let split = I.split +let merge = I.merge +let ofArray = I.ofArray \ No newline at end of file diff --git a/jscomp/others/bs_MapString.mli b/jscomp/others/bs_MapString.mli index 3f53b1e82a7..fa43d3457ed 100644 --- a/jscomp/others/bs_MapString.mli +++ b/jscomp/others/bs_MapString.mli @@ -5,19 +5,22 @@ type 'a t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t -(** The empty map. *) val ofArray: (key * 'a) array -> 'a t val isEmpty: 'a t -> bool -(** Test whether a map is empty or not. *) val mem: 'a t -> key -> bool -val add: 'a t -> key -> 'a -> 'a t +val update: 'a t -> key -> 'a -> 'a t (** [add m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) +val updateWithOpt: + 'a t -> + key -> + (key option -> 'a option [@bs]) -> + 'a t val singleton: key -> 'a -> 'a t @@ -85,14 +88,11 @@ val toList: 'a t -> (key * 'a) list given to {!Map.Make}. *) -val minBinding: 'a t -> (key * 'a) option -(** Return the smallest binding of the given map - or raise - *) +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null -val maxBinding: 'a t -> (key * 'a) option -(** returns the largest binding of the given map. - *) @@ -106,13 +106,10 @@ val split: key -> 'a t -> 'a t * 'a option * 'a t or [Some v] if [m] binds [v] to [x]. *) -val findOpt: key -> 'a t -> 'a option -(** [findOpt x m] returns the current binding of [x] in [m] *) - -val findAssert: key -> 'a t -> 'a -(** raise an exception if not there *) - +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn: 'a t -> key -> 'a val map: 'a t -> ('a -> 'b [@bs]) -> 'b t (** [map m f] returns a map with same domain as [m], where the diff --git a/jscomp/others/bs_MapStringM.ml b/jscomp/others/bs_MapStringM.ml new file mode 100644 index 00000000000..22f236d9a37 --- /dev/null +++ b/jscomp/others/bs_MapStringM.ml @@ -0,0 +1,108 @@ +# 6 "mapm.cppo.ml" +module I = Bs_internalMapString +module S = Bs_SortString +type key = string +# 12 +module N = Bs_internalAVLtree +module A = Bs_Array + + + + +type 'a t = { + mutable data : 'a I.t +} [@@bs.deriving abstract] + + +let empty () = t ~data:N.empty0 +let isEmpty m = N.isEmpty0 (data m) +let singleton k v = t ~data:(N.singleton0 k v) +let minKVOpt m = N.minKVOpt0 (data m) +let minKVNull m = N.minKVNull0 (data m) +let maxKVOpt m = N.maxKVOpt0 (data m) +let maxKVNull m = N.maxKVNull0 (data m) + +let addOnly (m : _ t) k v = + let old_data = data m in + let v = I.addMutate old_data k v in + if v != old_data then + dataSet m v + +let add (d : 'a t) (k : key) (v : 'a) : 'a t= + addOnly d k v; + d +let iter d f = N.iter0 (data d) f +let map d f = t ~data:(N.map0 (data d) f) +let mapi d f = t ~data:(N.mapi0 (data d) f) +let fold d acc f = N.fold0 (data d) acc f +let forAll d f = N.forAll0 (data d) f +let exists d f = N.exists0 (data d) f + +let length d = N.length0 (data d) +let toList d = N.toList0 (data d) +let checkInvariant d = N.checkInvariant (data d) +let mem d v = I.mem (data d) v + + +let rec removeMutateAux nt (x : key)= + let k = N.key nt in + if x = k then + let l,r = N.(left nt, right nt) in + match N.(toOpt l, toOpt r) with + | Some _, Some nr -> + N.rightSet nt (N.removeMinAuxWithRootMutate nt nr); + N.return (N.balMutate nt) + | None, Some _ -> + r + | (Some _ | None ), None -> l + else + begin + if x < k then + match N.toOpt (N.left nt) with + | None -> N.return nt + | Some l -> + N.leftSet nt (removeMutateAux l x ); + N.return (N.balMutate nt) + else + match N.toOpt (N.right nt) with + | None -> N.return nt + | Some r -> + N.rightSet nt (removeMutateAux r x); + N.return (N.balMutate nt) + end +let removeMutate nt x = + match N.toOpt nt with + | None -> nt + | Some nt -> removeMutateAux nt x + +let removeOnly d v = + let old_data = data d in + let v = removeMutate old_data v in + if v != old_data then + dataSet d v + +let remove d v = + removeOnly d v; + d + + +let cmp = I.cmp +let eq = I.eq + + +(* let split = I.split *) +(* let merge = I.merge *) + + +let ofArray xs = + t ~data:(I.ofArray xs) + +let cmp d0 d1 = + I.cmp (data d0) (data d1) +let eq d0 d1 = + I.eq (data d0) (data d1) +let findOpt d x = + I.findOpt (data d) x +let findNull d x = I.findNull (data d) x +let findWithDefault d x def = I.findWithDefault (data d) x def +let findExn d x = I.findExn (data d) x \ No newline at end of file diff --git a/jscomp/others/bs_MapStringM.mli b/jscomp/others/bs_MapStringM.mli new file mode 100644 index 00000000000..20f018dc31b --- /dev/null +++ b/jscomp/others/bs_MapStringM.mli @@ -0,0 +1,120 @@ +# 2 "mapm.cppo.mli" +type key = string +# 8 +type 'a t + + +val empty: unit -> 'a t + +val ofArray: (key * 'a) array -> 'a t + +val isEmpty: 'a t -> bool + +val mem: 'a t -> key -> bool + +val addOnly : 'a t -> key -> 'a -> unit +val add: 'a t -> key -> 'a -> 'a t +(** [add m x y] do the in-place modification, return + [m] for chaining. If [x] was already bound + in [m], its previous binding disappears. *) + +val singleton: key -> 'a -> 'a t + +val remove: 'a t -> key -> 'a t +(** [remove m x] do the in-place modification, return [m] for chaining *) + +(* val merge: + 'a t -> 'b t -> + (key -> 'a option -> 'b option -> 'c option [@bs]) -> + 'c t *) +(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + *) + +val cmp: 'a t -> 'a t -> ('a -> 'a -> int [@bs]) -> int + +val eq: 'a t -> 'a t -> ('a -> 'a -> bool [@bs]) -> bool +(** [equal m1 m2 cmp] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + +val iter: 'a t -> (key -> 'a -> unit [@bs]) -> unit +(** [iter m f] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + +val fold: 'a t -> 'b -> ('b -> key -> 'a -> 'b [@bs]) -> 'b +(** [fold m a f] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val forAll: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [forAll m p] checks if all the bindings of the map + satisfy the predicate [p]. + *) + +val exists: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [exists m p] checks if at least one binding of the map + satisfy the predicate [p]. + *) + +(* val filter: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t *) +(** [filter m p] returns the map with all the bindings in [m] + that satisfy predicate [p]. +*) + + +(* val partition: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t * 'a t *) +(** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + *) + +val length: 'a t -> int + + +val toList: 'a t -> (key * 'a) list +(** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + *) + +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null + + + + +(* val split: key -> 'a t -> 'a t * 'a option * 'a t *) +(** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + *) + +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null +val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn : 'a t -> key -> 'a + +val map: 'a t -> ('a -> 'b [@bs]) -> 'b t +(** [map m f] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: 'a t -> (key -> 'a -> 'b [@bs]) -> 'b t + + +val checkInvariant : _ t -> bool diff --git a/jscomp/others/bs_Set.ml b/jscomp/others/bs_Set.ml index 581d80e390c..98d84111410 100644 --- a/jscomp/others/bs_Set.ml +++ b/jscomp/others/bs_Set.ml @@ -10,13 +10,14 @@ type ('elt,'id) t = (('elt,'id) Bs_Cmp.t , ('elt,'id) t0) B.bag address equality means everything equal across time no need to call [bal] again *) -let rec add0 ~cmp (t : _ t0) x : _ t0 = +let rec add0 (t : _ t0) x ~cmp : _ t0 = match N.toOpt t with - None -> N.singleton0 x + | None -> N.singleton0 x | Some nt -> let k = N.key nt in let c = (Bs_Cmp.getCmp cmp) x k [@bs] in - if c = 0 then t else + if c = 0 then t + else let l,r = N.(left nt, right nt) in if c < 0 then let ll = add0 ~cmp l x in @@ -27,7 +28,7 @@ let rec add0 ~cmp (t : _ t0) x : _ t0 = if rr == r then t else N.bal l k rr -let rec remove0 ~cmp (t : _ t0) x : _ t0 = +let rec remove0 (t : _ t0) x ~cmp : _ t0 = match N.toOpt t with None -> t | Some n -> diff --git a/jscomp/others/bs_Set.mli b/jscomp/others/bs_Set.mli index 7a44567ea7d..7948d286458 100644 --- a/jscomp/others/bs_Set.mli +++ b/jscomp/others/bs_Set.mli @@ -108,8 +108,10 @@ val mem0: cmp: ('elt,'id) Bs_Cmp.cmp -> ('elt, 'id) t0 -> 'elt -> bool val add0: + ('elt, 'id) t0 -> + 'elt -> cmp: ('elt,'id) Bs_Cmp.cmp -> - ('elt, 'id) t0 -> 'elt -> ('elt, 'id) t0 + ('elt, 'id) t0 val addArray0: ('elt, 'id) t0 -> 'elt array -> cmp: ('elt,'id) Bs_Cmp.cmp -> @@ -121,8 +123,10 @@ val removeArray0: val singleton0: 'elt -> ('elt, 'id) t0 val remove0: + ('elt, 'id) t0 -> + 'elt -> cmp: ('elt,'id) Bs_Cmp.cmp -> - ('elt, 'id) t0 -> 'elt -> ('elt, 'id) t0 + ('elt, 'id) t0 val union0: cmp: ('elt,'id) Bs_Cmp.cmp -> ('elt, 'id) t0 -> ('elt, 'id) t0 -> ('elt, 'id) t0 diff --git a/jscomp/others/bs_SetInt.ml b/jscomp/others/bs_SetInt.ml index 9064d88bc5f..4eb32abfd91 100644 --- a/jscomp/others/bs_SetInt.ml +++ b/jscomp/others/bs_SetInt.ml @@ -27,13 +27,48 @@ let toArray = N.toArray0 let ofSortedArrayUnsafe = N.ofSortedArrayUnsafe0 let checkInvariant = N.checkInvariant -let add = I.add +let rec add (t : t) (x : elt) : t = + match N.toOpt t with + None -> N.singleton0 x + | Some nt -> + let v = N.key nt in + if x = v then t else + let l, r = N.(left nt , right nt) in + if x < v then + let ll = add l x in + if ll == l then t + else N.bal ll v r + else + let rr = add r x in + if rr == r then t + else N.bal l v (add r x) +let rec remove (t : t) (x : elt) : t = + match N.toOpt t with + | None -> t + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let v = ref (N.key rn) in + let r = N.removeMinAuxWithRef rn v in + N.bal l !v r + else + if x < v then + let ll = remove l x in + if ll == l then t + else N.bal ll v r + else + let rr = remove r x in + if rr == r then t + else N.bal l v rr let ofArray = I.ofArray let cmp = I.cmp let eq = I.eq let findOpt = I.findOpt let subset = I.subset -let remove = I.remove let mem = I.mem let rec splitAuxNoPivot (n : _ N.node) (x : elt) : t * t = @@ -93,7 +128,7 @@ let rec union (s1 : t) (s2 : t) = | Some n1, Some n2 (* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) *) -> let h1, h2 = N.(h n1 , h n2) in if h1 >= h2 then - if h2 = 1 then I.add s1 (N.key n2) else begin + if h2 = 1 then add s1 (N.key n2) else begin let l1, v1, r1 = N.(left n1, key n1, right n1) in let (l2, r2) = splitAuxNoPivot n2 v1 in N.joinShared (union l1 l2) v1 (union r1 r2) diff --git a/jscomp/others/bs_SetIntM.mli b/jscomp/others/bs_SetIntM.mli index 27b11d79065..eab7c425b7a 100644 --- a/jscomp/others/bs_SetIntM.mli +++ b/jscomp/others/bs_SetIntM.mli @@ -6,8 +6,10 @@ type t val empty: unit -> t val isEmpty: t -> bool val mem: t -> elt -> bool -val add: t -> elt -> t + val addOnly: t -> elt -> unit +val add: t -> elt -> t + val singleton: elt -> t val remove: t -> elt -> t val removeOnly: t -> elt -> unit diff --git a/jscomp/others/bs_SetString.ml b/jscomp/others/bs_SetString.ml index 0d7766d981f..8119c5229ec 100644 --- a/jscomp/others/bs_SetString.ml +++ b/jscomp/others/bs_SetString.ml @@ -27,13 +27,48 @@ let toArray = N.toArray0 let ofSortedArrayUnsafe = N.ofSortedArrayUnsafe0 let checkInvariant = N.checkInvariant -let add = I.add +let rec add (t : t) (x : elt) : t = + match N.toOpt t with + None -> N.singleton0 x + | Some nt -> + let v = N.key nt in + if x = v then t else + let l, r = N.(left nt , right nt) in + if x < v then + let ll = add l x in + if ll == l then t + else N.bal ll v r + else + let rr = add r x in + if rr == r then t + else N.bal l v (add r x) +let rec remove (t : t) (x : elt) : t = + match N.toOpt t with + | None -> t + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let v = ref (N.key rn) in + let r = N.removeMinAuxWithRef rn v in + N.bal l !v r + else + if x < v then + let ll = remove l x in + if ll == l then t + else N.bal ll v r + else + let rr = remove r x in + if rr == r then t + else N.bal l v rr let ofArray = I.ofArray let cmp = I.cmp let eq = I.eq let findOpt = I.findOpt let subset = I.subset -let remove = I.remove let mem = I.mem let rec splitAuxNoPivot (n : _ N.node) (x : elt) : t * t = @@ -93,7 +128,7 @@ let rec union (s1 : t) (s2 : t) = | Some n1, Some n2 (* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) *) -> let h1, h2 = N.(h n1 , h n2) in if h1 >= h2 then - if h2 = 1 then I.add s1 (N.key n2) else begin + if h2 = 1 then add s1 (N.key n2) else begin let l1, v1, r1 = N.(left n1, key n1, right n1) in let (l2, r2) = splitAuxNoPivot n2 v1 in N.joinShared (union l1 l2) v1 (union r1 r2) diff --git a/jscomp/others/bs_SetStringM.mli b/jscomp/others/bs_SetStringM.mli index 0f99a93211a..50cb8fe8a36 100644 --- a/jscomp/others/bs_SetStringM.mli +++ b/jscomp/others/bs_SetStringM.mli @@ -6,8 +6,10 @@ type t val empty: unit -> t val isEmpty: t -> bool val mem: t -> elt -> bool -val add: t -> elt -> t + val addOnly: t -> elt -> unit +val add: t -> elt -> t + val singleton: elt -> t val remove: t -> elt -> t val removeOnly: t -> elt -> unit diff --git a/jscomp/others/bs_Sort.ml b/jscomp/others/bs_Sort.ml index 47425715e15..5fe9bf788bf 100644 --- a/jscomp/others/bs_Sort.ml +++ b/jscomp/others/bs_Sort.ml @@ -25,6 +25,36 @@ module A = Bs_Array +let rec sortedLengthAuxMore xs prec acc len lt = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if lt v prec [@bs] then + sortedLengthAuxMore xs v (acc + 1) len lt + else acc + +let rec sortedLengthAuxLess xs prec acc len lt = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if lt prec v [@bs] then + sortedLengthAuxLess xs v (acc + 1) len lt + else acc + +let strictlySortedLength xs lt = + let len = A.length xs in + match len with + | 0 | 1 -> len + | _ -> + let x0, x1 = A.unsafe_get xs 0, A.unsafe_get xs 1 in + (* let c = cmp x0 x1 [@bs] in *) + if lt x0 x1 [@bs] then + sortedLengthAuxLess xs x1 2 len lt + else if lt x1 x0 [@bs] then + - (sortedLengthAuxMore xs x1 2 len lt) + else 1 + + let rec isSortedAux a i cmp last_bound = (* when [i = len - 1], it reaches the last element*) if i = last_bound then true diff --git a/jscomp/others/bs_Sort.mli b/jscomp/others/bs_Sort.mli index a6f667576e9..7b50d8ce06a 100644 --- a/jscomp/others/bs_Sort.mli +++ b/jscomp/others/bs_Sort.mli @@ -1,6 +1,41 @@ +(* Copyright (C) 2017 Authors of BuckleScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + + +val strictlySortedLength : + 'a array -> + ('a -> 'a -> bool [@bs]) -> + int +(** + [strictlySortedLenght xs cmp] + return [+n] means increasing order + [-n] means negative order +*) + val isSorted : 'a array -> ('a -> 'a -> int [@bs]) -> bool (** [isSorted arr cmp] returns true if array is increeasingly sorted diff --git a/jscomp/others/bs_SortInt.ml b/jscomp/others/bs_SortInt.ml index e49af1b359d..b9177c61280 100644 --- a/jscomp/others/bs_SortInt.ml +++ b/jscomp/others/bs_SortInt.ml @@ -4,6 +4,34 @@ type elt = int # 9 module A = Bs_Array +let rec sortedLengthAuxMore (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec > v then + sortedLengthAuxMore xs v (acc + 1) len + else acc + +let rec sortedLengthAuxLess (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec < v then + sortedLengthAuxLess xs v (acc + 1) len + else acc + +let strictlySortedLength (xs : elt array) = + let len = A.length xs in + match len with + | 0 | 1 -> len + | _ -> + let x0, x1 = A.unsafe_get xs 0, A.unsafe_get xs 1 in + (* let c = cmp x0 x1 [@bs] in *) + if x0 < x1 then + sortedLengthAuxLess xs x1 2 len + else if x0 > x1 then + - (sortedLengthAuxMore xs x1 2 len) + else 1 let rec isSortedAux (a : elt array) i last_bound = (* when [i = len - 1], it reaches the last element*) diff --git a/jscomp/others/bs_SortInt.mli b/jscomp/others/bs_SortInt.mli index 6ceb04ee891..49d2f1d3550 100644 --- a/jscomp/others/bs_SortInt.mli +++ b/jscomp/others/bs_SortInt.mli @@ -1,8 +1,16 @@ # 2 "sort.cppo.mli" type elt = int +# 9 +val strictlySortedLength : + elt array -> + int +(** + [strictlySortedLenght xs] + return [+n] means increasing order + [-n] means negative order +*) -# 10 val isSorted : elt array -> bool (** strictly sorted *) diff --git a/jscomp/others/bs_SortString.ml b/jscomp/others/bs_SortString.ml index 629d2f6bac3..432eb69733e 100644 --- a/jscomp/others/bs_SortString.ml +++ b/jscomp/others/bs_SortString.ml @@ -4,6 +4,34 @@ type elt = string # 9 module A = Bs_Array +let rec sortedLengthAuxMore (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec > v then + sortedLengthAuxMore xs v (acc + 1) len + else acc + +let rec sortedLengthAuxLess (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec < v then + sortedLengthAuxLess xs v (acc + 1) len + else acc + +let strictlySortedLength (xs : elt array) = + let len = A.length xs in + match len with + | 0 | 1 -> len + | _ -> + let x0, x1 = A.unsafe_get xs 0, A.unsafe_get xs 1 in + (* let c = cmp x0 x1 [@bs] in *) + if x0 < x1 then + sortedLengthAuxLess xs x1 2 len + else if x0 > x1 then + - (sortedLengthAuxMore xs x1 2 len) + else 1 let rec isSortedAux (a : elt array) i last_bound = (* when [i = len - 1], it reaches the last element*) diff --git a/jscomp/others/bs_SortString.mli b/jscomp/others/bs_SortString.mli index b32fa5f7057..a72d2de1628 100644 --- a/jscomp/others/bs_SortString.mli +++ b/jscomp/others/bs_SortString.mli @@ -1,8 +1,16 @@ # 4 "sort.cppo.mli" type elt = string +# 9 +val strictlySortedLength : + elt array -> + int +(** + [strictlySortedLenght xs] + return [+n] means increasing order + [-n] means negative order +*) -# 10 val isSorted : elt array -> bool (** strictly sorted *) diff --git a/jscomp/others/bs_Stack.ml b/jscomp/others/bs_Stack.ml index 3dbea0766f9..e55283dd58f 100644 --- a/jscomp/others/bs_Stack.ml +++ b/jscomp/others/bs_Stack.ml @@ -91,7 +91,7 @@ let iter s f = let dynamicPopIter s f = let cursor = ref (root s) in while !cursor != Js.null do - let v = Js.Null.castUnsafe !cursor in + let v = Js.Null.getUnsafe !cursor in rootSet s (tail v); f (head v) [@bs]; cursor := root s (* using root, [f] may change it*) diff --git a/jscomp/others/bs_internalAVLset.ml b/jscomp/others/bs_internalAVLset.ml index d611ba58337..15a377f776c 100644 --- a/jscomp/others/bs_internalAVLset.ml +++ b/jscomp/others/bs_internalAVLset.ml @@ -33,6 +33,7 @@ type 'elt node = { [@@bs.deriving abstract] module A = Bs_Array +module S = Bs_Sort external toOpt : 'a Js.null -> 'a option = "#null_to_opt" external return : 'a -> 'a Js.null = "%identity" @@ -142,7 +143,7 @@ let rec removeMinAuxWithRef n v = match toOpt ln with | None -> v:= kn ; rn | Some ln -> bal (removeMinAuxWithRef ln v) kn rn - + @@ -156,7 +157,7 @@ let rec stackAllLeft v s = match toOpt v with | None -> s | Some x -> stackAllLeft (left x) (x::s) - + let rec iter0 n f = match toOpt n with @@ -209,7 +210,7 @@ let rec addMaxElement n v = | None -> singleton0 v | Some n -> bal (left n) (key n) (addMaxElement (right n) v) - + (* [join ln v rn] return a balanced tree simliar to [create ln v rn] bal, but no assumptions are made on the relative heights of [ln] and [rn]. *) @@ -224,7 +225,7 @@ let rec joinShared ln v rn = if lh > rh + 2 then bal (left l) (key l) (joinShared (right l) v rn) else if rh > lh + 2 then bal (joinShared ln v (left r)) (key r) (right r) else create ln v rn - + (* [concat l r] No assumption on the heights of l and r. *) @@ -236,8 +237,8 @@ let concatShared t1 t2 = let v = ref (key t2n ) in let t2r = removeMinAuxWithRef t2n v in joinShared t1 !v t2r - - + + let rec partitionShared0 n p = match toOpt n with @@ -311,24 +312,24 @@ type cursor = let rec fillArrayWithPartition n cursor arr p = let l,v,r = left n, key n, right n in (match toOpt l with - | None -> () - | Some l -> - fillArrayWithPartition l cursor arr p); + | None -> () + | Some l -> + fillArrayWithPartition l cursor arr p); (if p v [@bs] then begin let c = forward cursor in A.unsafe_set arr c v; forwardSet cursor (c + 1) - end - else begin - let c = backward cursor in - A.unsafe_set arr c v ; - backwardSet cursor (c - 1) - end); + end + else begin + let c = backward cursor in + A.unsafe_set arr c v ; + backwardSet cursor (c - 1) + end); match toOpt r with | None -> () | Some r -> fillArrayWithPartition r cursor arr p - + let rec fillArrayWithFilter n i arr p = let l,v,r = left n, key n, right n in let next = @@ -339,7 +340,7 @@ let rec fillArrayWithFilter n i arr p = let rnext = if p v [@bs] then (A.unsafe_set arr next v; - next + 1 + next + 1 ) else next in match toOpt r with @@ -381,7 +382,7 @@ let rec ofSortedArrayRevAux arr off len = let right = ofSortedArrayRevAux arr (off - nl - 1) (len - nl - 1) in create left mid right - + let rec ofSortedArrayAux arr off len = match len with @@ -410,7 +411,7 @@ let rec ofSortedArrayAux arr off len = let ofSortedArrayUnsafe0 arr = ofSortedArrayAux arr 0 (A.length arr) - + let rec filterShared0 n p = match toOpt n with | None -> empty @@ -421,8 +422,8 @@ let rec filterShared0 n p = let newR = filterShared0 r p in if pv then (if l == newL && r == newR then - return n - else joinShared newL v newR) + return n + else joinShared newL v newR) else concatShared newL newR (* ATT: functional methods in general can be shared with imperative methods, however, it does not apply when functional @@ -476,7 +477,7 @@ let rec compareAux e1 e2 ~cmp = let cmp0 s1 s2 ~cmp = let len1,len2 = length0 s1, length0 s2 in if len1 = len2 then - compareAux ~cmp (stackAllLeft s1 []) (stackAllLeft s2 []) + compareAux ~cmp (stackAllLeft s1 []) (stackAllLeft s2 []) else if len1 < len2 then -1 else 1 @@ -520,14 +521,7 @@ let rec findNull0 ~cmp (n : _ t0) x = if c = 0 then return v else findNull0 ~cmp (if c < 0 then left t else right t) x -let rec sortedLengthAux ~cmp (xs : _ array) prec acc len = - if acc >= len then acc - else - let v = A.unsafe_get xs acc in - if cmp v prec [@bs] >= 0 then - sortedLengthAux ~cmp xs v (acc + 1) len - else acc - + (******************************************************************) (* @@ -620,15 +614,20 @@ let ofArray0 ~cmp (xs : _ array) = let len = A.length xs in if len = 0 then empty0 else - let next = sortedLengthAux - ~cmp:(Bs_Cmp.getCmp cmp) xs (A.unsafe_get xs 0) 1 len in - let result = ref (ofSortedArrayAux xs 0 next) in - for i = next to len - 1 do + let next = ref (S.strictlySortedLength xs + (fun [@bs] x y -> (Bs_Cmp.getCmp cmp) x y [@bs] < 0)) in + let result = + ref (if !next >= 0 then + ofSortedArrayAux xs 0 !next + else begin + next := - !next ; + ofSortedArrayRevAux xs (!next - 1) !next + end) in + for i = !next to len - 1 do result := addMutate ~cmp !result (A.unsafe_get xs i) done ; !result - let rec removeMinAuxWithRootMutate nt n = let rn, ln = right n, left n in match toOpt ln with diff --git a/jscomp/others/bs_internalAVLset.mli b/jscomp/others/bs_internalAVLset.mli index 4a875150cf5..66379ff9771 100644 --- a/jscomp/others/bs_internalAVLset.mli +++ b/jscomp/others/bs_internalAVLset.mli @@ -59,7 +59,9 @@ val removeMinAuxWithRef : 'a node -> 'a ref -> 'a t0 minimum removed and stored in cell *) val empty0 : 'a t0 val isEmpty0 : 'a t0 -> bool + val stackAllLeft : 'a t0 -> 'a node list -> 'a node list + val iter0 : 'a t0 -> ('a -> 'b [@bs]) -> unit val fold0 : 'a t0 -> 'b -> ('b -> 'a -> 'b [@bs]) -> 'b val forAll0 : 'a t0 -> ('a -> bool [@bs]) -> bool @@ -83,6 +85,7 @@ val checkInvariant : _ t0 -> bool val fillArray: 'a node -> int -> 'a array -> int val toArray0 : 'a t0 -> 'a array val ofSortedArrayAux : 'a array -> int -> int -> 'a t0 +val ofSortedArrayRevAux : 'a array -> int -> int -> 'a t0 val ofSortedArrayUnsafe0 : 'a array -> 'a t0 val mem0 : cmp:('a, 'b) Bs_Cmp.cmp -> 'a t0 -> 'a -> bool val cmp0 : 'a t0 -> 'a t0 -> cmp:('a, 'b) Bs_Cmp.cmp -> int diff --git a/jscomp/others/bs_internalAVLtree.ml b/jscomp/others/bs_internalAVLtree.ml index 860cf96abed..3489128b54b 100644 --- a/jscomp/others/bs_internalAVLtree.ml +++ b/jscomp/others/bs_internalAVLtree.ml @@ -21,6 +21,7 @@ type ('k, 'v) node = { mutable h : int } [@@bs.deriving abstract] module A = Bs_Array +module S = Bs_Sort external toOpt : 'a Js.null -> 'a option = "#null_to_opt" external return : 'a -> 'a Js.null = "%identity" external empty : 'a Js.null = "#null" @@ -47,6 +48,20 @@ let create l x d r = let singleton0 x d = return @@ node ~left:empty ~key:x ~value:d ~right:empty ~h:1 +let heightGe l r = + match toOpt l, toOpt r with + | _, None -> true + | Some hl, Some hr -> h hl >= h hr + | None, Some _ -> false + +let updateKV n key value = + return @@ node + ~left:(left n) + ~right:(right n) + ~key + ~value + ~h:(h n) + let bal l x d r = let hl = match toOpt l with None -> 0 | Some n -> h n in let hr = match toOpt r with None -> 0 | Some n -> h n in @@ -153,7 +168,7 @@ let rec fold0 m accu f = | Some n -> let l, v, d, r = left n, key n, value n, right n in fold0 - r + r (f (fold0 l accu f) v d [@bs]) f let rec forAll0 n p = @@ -226,26 +241,40 @@ let concatOrJoin t1 v d t2 = | Some d -> join t1 v d t2 | None -> concat t1 t2 -let rec filter0 p n = +let rec filterShared0 p n = match toOpt n with - None -> n + None -> empty | Some n -> (* call [p] in the expected left-to-right order *) let v, d = key n, value n in - let newLeft = filter0 p (left n) in + let newLeft = filterShared0 p (left n) in let pvd = p v d [@bs] in - let newRight = filter0 p (right n) in + let newRight = filterShared0 p (right n) in if pvd then join newLeft v d newRight else concat newLeft newRight -let rec partition0 p n = +let rec filterMap0 n p = + match toOpt n with + None -> empty + | Some n -> + (* call [p] in the expected left-to-right order *) + let v, d = key n, value n in + let newLeft = filterMap0 (left n) p in + let pvd = p v d [@bs] in + let newRight = filterMap0 (right n) p in + match pvd with + | None -> concat newLeft newRight + | Some d -> join newLeft v d newRight + + +let rec partitionShared0 p n = match toOpt n with None -> (empty, empty) | Some n -> let key, value = key n, value n in (* call [p] in the expected left-to-right order *) - let (lt, lf) = partition0 p (left n) in + let (lt, lf) = partitionShared0 p (left n) in let pvd = p key value [@bs] in - let (rt, rf) = partition0 p (right n) in + let (rt, rf) = partitionShared0 p (right n) in if pvd then (join lt key value rt, concat lf rf) else (concat lt rt, join lf key value rf) @@ -289,6 +318,34 @@ let rec checkInvariant (v : _ t0) = diff <=2 && diff >= -2 && checkInvariant l && checkInvariant r +let rec fillArrayKey n i arr = + let l,v,r = left n, key n, right n in + let next = + match toOpt l with + | None -> i + | Some l -> + fillArrayKey l i arr in + A.unsafe_set arr next v; + let rnext = next + 1 in + match toOpt r with + | None -> rnext + | Some r -> + fillArrayKey r rnext arr + +let rec fillArrayValue n i arr = + let l,r = left n, right n in + let next = + match toOpt l with + | None -> i + | Some l -> + fillArrayValue l i arr in + A.unsafe_set arr next (value n); + let rnext = next + 1 in + match toOpt r with + | None -> rnext + | Some r -> + fillArrayValue r rnext arr + let rec fillArray n i arr = let l,v,r = left n, key n, right n in let next = @@ -309,24 +366,24 @@ type cursor = let rec fillArrayWithPartition n cursor arr p = let l,v,r = left n, key n, right n in (match toOpt l with - | None -> () - | Some l -> - fillArrayWithPartition l cursor arr p); + | None -> () + | Some l -> + fillArrayWithPartition l cursor arr p); (if p v [@bs] then begin let c = forward cursor in A.unsafe_set arr c (v,value n); forwardSet cursor (c + 1) - end - else begin - let c = backward cursor in - A.unsafe_set arr c (v, value n); - backwardSet cursor (c - 1) - end); + end + else begin + let c = backward cursor in + A.unsafe_set arr c (v, value n); + backwardSet cursor (c - 1) + end); match toOpt r with | None -> () | Some r -> fillArrayWithPartition r cursor arr p - + let rec fillArrayWithFilter n i arr p = let l,v,r = left n, key n, right n in let next = @@ -337,7 +394,7 @@ let rec fillArrayWithFilter n i arr p = let rnext = if p v [@bs] then (A.unsafe_set arr next (v, value n); - next + 1 + next + 1 ) else next in match toOpt r with @@ -355,6 +412,24 @@ let toArray0 n = ignore (fillArray n 0 v : int); (* may add assertion *) v +let keysToArray0 n = + match toOpt n with + | None -> [||] + | Some n -> + let size = lengthNode n in + let v = A.makeUninitializedUnsafe size in + ignore (fillArrayKey n 0 v : int); (* may add assertion *) + v + +let valuesToArray0 n = + match toOpt n with + | None -> [||] + | Some n -> + let size = lengthNode n in + let v = A.makeUninitializedUnsafe size in + ignore (fillArrayValue n 0 v : int); (* may add assertion *) + v + let rec ofSortedArrayRevAux arr off len = match len with | 0 -> empty0 @@ -380,7 +455,7 @@ let rec ofSortedArrayRevAux arr off len = let right = ofSortedArrayRevAux arr (off - nl - 1) (len - nl - 1) in create left midK midV right - + let rec ofSortedArrayAux arr off len = match len with @@ -406,7 +481,216 @@ let rec ofSortedArrayAux arr off len = let right = ofSortedArrayAux arr (off + nl + 1) (len - nl - 1) in create left midK midV right - + let ofSortedArrayUnsafe0 arr = ofSortedArrayAux arr 0 (A.length arr) - \ No newline at end of file + +let rec compareAux e1 e2 ~kcmp ~vcmp = + match e1,e2 with + | h1::t1, h2::t2 -> + let c = (Bs_Cmp.getCmp kcmp) (key h1) (key h2) [@bs] in + if c = 0 then + let cx = vcmp (value h1) (value h2) [@bs] in + if cx = 0 then + compareAux ~kcmp ~vcmp + (stackAllLeft (right h1) t1 ) + (stackAllLeft (right h2) t2) + else cx + else c + | _, _ -> 0 + +let rec eqAux e1 e2 ~kcmp ~vcmp = + match e1,e2 with + | h1::t1, h2::t2 -> + if (Bs_Cmp.getCmp kcmp) (key h1) (key h2) [@bs] = 0 && + vcmp (value h1) (value h2) [@bs] then + eqAux ~kcmp ~vcmp ( + stackAllLeft (right h1) t1 ) (stackAllLeft (right h2) t2) + else false + | _, _ -> true + +let cmp0 s1 s2 ~kcmp ~vcmp = + let len1,len2 = length0 s1, length0 s2 in + if len1 = len2 then + compareAux (stackAllLeft s1 []) (stackAllLeft s2 []) ~kcmp ~vcmp + else if len1 < len2 then -1 else 1 + +let eq0 s1 s2 ~kcmp ~vcmp = + let len1, len2 = length0 s1, length0 s2 in + if len1 = len2 then + eqAux (stackAllLeft s1 []) (stackAllLeft s2 []) ~kcmp ~vcmp + else false + +let rec findOpt0 n x ~cmp = + match toOpt n with + None -> None + | Some n (* Node(l, v, d, r, _) *) -> + let v = key n in + let c = (Bs_Cmp.getCmp cmp) x v [@bs] in + if c = 0 then Some (value n) + else findOpt0 ~cmp (if c < 0 then left n else right n) x + +let rec findNull0 n x ~cmp = + match toOpt n with + | None -> Js.null + | Some n -> + let v = key n in + let c = (Bs_Cmp.getCmp cmp) x v [@bs] in + if c = 0 then return (value n ) + else findNull0 ~cmp (if c < 0 then left n else right n) x + +let rec findExn0 n x ~cmp = + match toOpt n with + None -> + [%assert "findExn0"] + | Some n (* Node(l, v, d, r, _)*) -> + let v = key n in + let c = (Bs_Cmp.getCmp cmp) x v [@bs] in + if c = 0 then value n + else findExn0 ~cmp (if c < 0 then left n else right n) x + +let rec findWithDefault0 n x def ~cmp = + match toOpt n with + None -> + def + | Some n (* Node(l, v, d, r, _)*) -> + let v = key n in + let c = (Bs_Cmp.getCmp cmp) x v [@bs] in + if c = 0 then value n + else findWithDefault0 ~cmp (if c < 0 then left n else right n) x def + +let rec mem0 n x ~cmp = + match toOpt n with + None -> + false + | Some n (* Node(l, v, d, r, _) *) -> + let v = key n in + let c = (Bs_Cmp.getCmp cmp) x v [@bs] in + c = 0 || mem0 ~cmp (if c < 0 then left n else right n) x + + +(******************************************************************) + +(* + L rotation, return root node +*) +let rotateWithLeftChild k2 = + let k1 = unsafeCoerce (left k2) in + (leftSet k2 (right k1)); + (rightSet k1 (return k2 )); + let hlk2, hrk2 = (height (left k2), (height (right k2))) in + (hSet k2 + (Pervasives.max hlk2 hrk2 + 1)); + let hlk1, hk2 = (height (left k1), (h k2)) in + (hSet k1 (Pervasives.max hlk1 hk2 + 1)); + k1 +(* right rotation *) +let rotateWithRightChild k1 = + let k2 = unsafeCoerce (right k1) in + (rightSet k1 (left k2)); + (leftSet k2 (return k1)); + let hlk1, hrk1 = ((height (left k1)), (height (right k1))) in + (hSet k1 (Pervasives.max hlk1 hrk1 + 1)); + let hrk2, hk1 = (height (right k2), (h k1)) in + (hSet k2 (Pervasives.max hrk2 hk1 + 1)); + k2 + +(* + double l rotation +*) +let doubleWithLeftChild k3 = + let v = rotateWithRightChild (unsafeCoerce (left k3)) in + (leftSet k3 (return v )); + rotateWithLeftChild k3 + +let doubleWithRightChild k2 = + let v = rotateWithLeftChild (unsafeCoerce (right k2)) in + (rightSet k2 (return v)); + rotateWithRightChild k2 + +let heightUpdateMutate t = + let hlt, hrt = (height (left t),(height (right t))) in + hSet t (Pervasives.max hlt hrt + 1); + t + +let balMutate nt = + let l, r = (left nt, right nt) in + let hl, hr = (height l, height r) in + if hl > 2 + hr then + let l = unsafeCoerce l in + let ll, lr = (left l , right l)in + (if heightGe ll lr then + heightUpdateMutate (rotateWithLeftChild nt) + else + heightUpdateMutate (doubleWithLeftChild nt) + ) + else + if hr > 2 + hl then + let r = unsafeCoerce r in + let rl,rr = (left r, right r) in + (if heightGe rr rl then + heightUpdateMutate (rotateWithRightChild nt) + else + heightUpdateMutate (doubleWithRightChild nt) + ) + else + begin + hSet nt (max hl hr + 1); + nt + end + +let rec addMutate ~cmp (t : _ t0) x data = + match toOpt t with + | None -> singleton0 x data + | Some nt -> + let k = key nt in + let c = (Bs_Cmp.getCmp cmp) x k [@bs] in + if c = 0 then begin + keySet nt x; + valueSet nt data; + return nt + end + else + let l, r = (left nt, right nt) in + (if c < 0 then + let ll = addMutate ~cmp l x data in + leftSet nt ll + else + rightSet nt (addMutate ~cmp r x data); + ); + return (balMutate nt) + +let ofArray0 ~cmp (xs : _ array) = + let len = A.length xs in + if len = 0 then empty0 + else + let next = + ref (S.strictlySortedLength xs + (fun[@bs] (x0,_) (y0,_) -> + (Bs_Cmp.getCmp cmp) x0 y0 [@bs] < 0 + )) + in + let result = ref ( + if !next >= 0 then + ofSortedArrayAux xs 0 !next + else begin + next := - !next; + ofSortedArrayRevAux xs (!next - 1) (!next) + end + ) in + for i = !next to len - 1 do + let k, v = (A.unsafe_get xs i) in + result := addMutate ~cmp !result k v + done ; + !result + + +let rec removeMinAuxWithRootMutate nt n = + let rn, ln = right n, left n in + match toOpt ln with + | None -> + keySet nt (key n); + rn + | Some ln -> + leftSet n (removeMinAuxWithRootMutate nt ln); + return (balMutate n) diff --git a/jscomp/others/bs_internalAVLtree.mli b/jscomp/others/bs_internalAVLtree.mli index a53661a262a..82a5f406be3 100644 --- a/jscomp/others/bs_internalAVLtree.mli +++ b/jscomp/others/bs_internalAVLtree.mli @@ -26,11 +26,11 @@ type ('key, 'a) t0 = ('key, 'a) node Js.null -and ('k, 'v) node = { - left : ('k,'v) t0; - key : 'k; - value : 'v; - right : ('k,'v) t0; +and ('k, 'v) node = private { + mutable left : ('k,'v) t0; + mutable key : 'k; + mutable value : 'v; + mutable right : ('k,'v) t0; h : int } [@@bs.deriving abstract] @@ -45,6 +45,7 @@ val bal : ('a,'b) t0 -> 'a -> 'b -> ('a,'b) t0 -> ('a,'b) t0 val singleton0 : 'a -> 'b -> ('a,'b) t0 +val updateKV : ('k, 'v) node -> 'k -> 'v -> ('k,'v) t0 val minKVOpt0 : ('a,'b) t0 -> ('a * 'b) option val minKVNull0 : ('a,'b) t0 -> ('a * 'b) Js.null val maxKVOpt0 : ('a,'b) t0 -> ('a * 'b) option @@ -72,8 +73,17 @@ val concat : ('a,'b) t0 -> ('a,'b) t0 -> ('a,'b) t0 val concatOrJoin : ('a,'b) t0 -> 'a -> 'b option -> ('a,'b) t0 -> ('a, 'b) t0 -val filter0 : ('a -> 'b -> bool [@bs]) -> ('a,'b) t0 -> ('a,'b) t0 -val partition0 : +val filterShared0 : + ('a -> 'b -> bool [@bs]) -> + ('a,'b) t0 -> + ('a,'b) t0 + +val filterMap0 : + ('a, 'b) t0 -> + ('a -> 'b -> 'c option [@bs]) -> + ('a, 'c) t0 +(* seems no sharing, could be shared with mutation *) +val partitionShared0 : ('a -> 'b -> bool [@bs]) -> ('a,'b) t0 -> ('a,'b) t0 * ('a,'b) t0 @@ -85,6 +95,69 @@ val toList0 : ('a,'b) t0 -> ('a * 'b) list val checkInvariant : ('a,'b) t0 -> bool val fillArray : ('a,'b) node -> int -> ('a * 'b) array -> int -val toArray0 : ('a,'b) t0 -> ('a * 'b) array + +val toArray0 : ('a, 'b) t0 -> ('a * 'b) array +val keysToArray0 : ('a, 'b) t0 -> 'a array +val valuesToArray0 : ('a, 'b) t0 -> 'b array val ofSortedArrayAux : ('a * 'b) array -> int -> int -> ('a, 'b) t0 -val ofSortedArrayUnsafe0 : ('a * 'b) array -> ('a, 'b) t0 \ No newline at end of file +val ofSortedArrayRevAux : ('a * 'b) array -> int -> int -> ('a, 'b) t0 +val ofSortedArrayUnsafe0 : ('a * 'b) array -> ('a, 'b) t0 + +val cmp0 : + ('a, 'b) t0 -> ('a, 'c) t0 -> + kcmp:('a,_) Bs_Cmp.cmp -> + vcmp :('b -> 'c -> int [@bs]) -> + int + +val eq0: + ('a, 'b) t0 -> ('a, 'c) t0 -> + kcmp:('a,_) Bs_Cmp.cmp -> + vcmp :('b -> 'c -> bool [@bs]) -> + bool + +val findOpt0: + ('a, 'b) t0 -> + 'a -> + cmp:('a,_) Bs_Cmp.cmp -> + 'b option + +val findNull0: + ('a, 'b) t0 -> + 'a -> + cmp:('a,_) Bs_Cmp.cmp -> + 'b Js.null + +val findWithDefault0: + ('a, 'b) t0 -> + 'a -> + 'b -> + cmp:('a,_) Bs_Cmp.cmp -> + 'b +val findExn0: + ('a, 'b) t0 -> + 'a -> + cmp:('a,_) Bs_Cmp.cmp -> + 'b + +val mem0: + ('a, 'b) t0 -> + 'a -> + cmp:('a,_) Bs_Cmp.cmp -> + bool + + + +val ofArray0 : cmp:('a,'id) Bs_Cmp.cmp -> ('a * 'b) array -> ('a, 'b) t0 + +val addMutate : + cmp:('a,'id) Bs_Cmp.cmp -> + ('a, 'b) t0 -> 'a -> 'b -> + ('a, 'b) t0 + +val balMutate : + ('a, 'b) node -> ('a, 'b) node + +val removeMinAuxWithRootMutate : + ('a, 'b) node -> + ('a, 'b) node -> + ('a, 'b) t0 \ No newline at end of file diff --git a/jscomp/others/bs_internalMapInt.ml b/jscomp/others/bs_internalMapInt.ml new file mode 100644 index 00000000000..978a52be82a --- /dev/null +++ b/jscomp/others/bs_internalMapInt.ml @@ -0,0 +1,219 @@ +# 4 "internal_map.cppo.ml" +type key = int + +# 9 +module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort +type ('key, 'a, 'id) t0 = ('key,'a) N.t0 + +type 'a t = (key,'a) N.t0 + +let rec add t (x : key) (data : _) = + match N.toOpt t with + | None -> + N.singleton0 x data + | Some n -> + let k = N.key n in + if x = k then + N.updateKV n x data + else + let v = N.value n in + if x < k then + N.bal (add (N.left n) x data ) k v (N.right n) + else + N.bal (N.left n) k v (add (N.right n) x data ) + +let rec findOpt n (x : key) = + match N.toOpt n with + None -> None + | Some n -> + let v = N.key n in + if x = v then Some (N.value n) + else findOpt (if x < v then N.left n else N.right n) x + +let rec findNull n (x : key) = + match N.toOpt n with + | None -> + Js.null + | Some n -> + let v = N.key n in + if x = v then N.return (N.value n) + else findNull (if x < v then (N.left n) else (N.right n)) x + +let rec findExn n (x : key) = + match N.toOpt n with + | None -> [%assert "findExn"] + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findExn (if x < v then (N.left n) else (N.right n)) x + +let rec findWithDefault n (x : key) def = + match N.toOpt n with + | None -> def + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findWithDefault (if x < v then (N.left n) else (N.right n)) x def + +let rec mem n (x : key)= + match N.toOpt n with + None -> false + | Some n (* Node(l, v, d, r, _) *) -> + let v = N.key n in + x = v || mem (if x < v then N.left n else N.right n) x + +let rec remove n (x : key) = + match N.toOpt n with + | None -> n + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let kr, vr = ref (N.key rn), ref (N.value rn) in + let r = N.removeMinAuxWithRef rn kr vr in + N.bal l !kr !vr r + else if x < v then + N.(bal (remove l x ) v (value n) r) + else + N.(bal l v (value n) (remove r x )) + +let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = + let l,v,d,r = N.(left n , key n, value n, right n) in + if x = v then (l, Some d, r) + else + if x < v then + match N.toOpt l with + | None -> + N.(empty , None, return n) + | Some l -> + let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) + else + match N.toOpt r with + | None -> + N.(return n, None, empty) + | Some r -> + let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) + + +let rec split (x : key) n = + match N.toOpt n with + None -> + N.(empty, None, empty) + | Some n -> + splitAux x n + +let rec merge s1 s2 f = + match N.(toOpt s1, toOpt s2) with + (None, None) -> N.empty + | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ + when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> + let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in + let (l2, d2, r2) = split v1 s2 in + N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) + | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> + let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in + let (l1, d1, r1) = split v2 s1 in + N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) + | _ -> + assert false + +let rec compareAux e1 e2 vcmp = + match e1,e2 with + | h1::t1, h2::t2 -> + let c = Pervasives.compare (N.key h1 : key) (N.key h2) in + if c = 0 then + let cx = vcmp (N.value h1) (N.value h2) [@bs] in + if cx = 0 then + compareAux + (N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + vcmp + else cx + else c + | _, _ -> 0 + +let cmp s1 s2 cmp = + let len1, len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + compareAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) + cmp + else if len1 < len2 then -1 + else 1 + + +let rec eqAux e1 e2 eq = + match e1,e2 with + | h1::t1, h2::t2 -> + if (N.key h1 : key) = (N.key h2) && + eq (N.value h1) (N.value h2) [@bs] then + eqAux ( + N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + eq + else false + | _, _ -> true (*end *) + +let eq s1 s2 eq = + let len1,len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + eqAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) eq + else false + +let rec addMutate (t : _ t) x data : _ t = + match N.toOpt t with + | None -> N.singleton0 x data + | Some nt -> + let k = N.key nt in + (* let c = (Bs_Cmp.getCmp cmp) x k [@bs] in *) + if x = k then begin + N.keySet nt x; + N.valueSet nt data; + N.return nt + end + else + let l, r = (N.left nt, N.right nt) in + (if x < k then + let ll = addMutate l x data in + N.leftSet nt ll + else + N.rightSet nt (addMutate r x data); + ); + N.return (N.balMutate nt) + +let ofArray (xs : (key * _) array) = + let len = A.length xs in + if len = 0 then N.empty0 + else + let next = + ref (S.strictlySortedLength xs + (fun[@bs] (x0,_) (y0,_) -> + x0 < y0 + )) + in + let result = ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next; + N.ofSortedArrayRevAux xs (!next - 1) (!next) + end + ) in + for i = !next to len - 1 do + let k, v = (A.unsafe_get xs i) in + result := addMutate !result k v + done ; + !result + + + + + diff --git a/jscomp/others/bs_internalMapString.ml b/jscomp/others/bs_internalMapString.ml new file mode 100644 index 00000000000..7b5b21c1e14 --- /dev/null +++ b/jscomp/others/bs_internalMapString.ml @@ -0,0 +1,219 @@ +# 2 "internal_map.cppo.ml" +type key = string + +# 9 +module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort +type ('key, 'a, 'id) t0 = ('key,'a) N.t0 + +type 'a t = (key,'a) N.t0 + +let rec add t (x : key) (data : _) = + match N.toOpt t with + | None -> + N.singleton0 x data + | Some n -> + let k = N.key n in + if x = k then + N.updateKV n x data + else + let v = N.value n in + if x < k then + N.bal (add (N.left n) x data ) k v (N.right n) + else + N.bal (N.left n) k v (add (N.right n) x data ) + +let rec findOpt n (x : key) = + match N.toOpt n with + None -> None + | Some n -> + let v = N.key n in + if x = v then Some (N.value n) + else findOpt (if x < v then N.left n else N.right n) x + +let rec findNull n (x : key) = + match N.toOpt n with + | None -> + Js.null + | Some n -> + let v = N.key n in + if x = v then N.return (N.value n) + else findNull (if x < v then (N.left n) else (N.right n)) x + +let rec findExn n (x : key) = + match N.toOpt n with + | None -> [%assert "findExn"] + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findExn (if x < v then (N.left n) else (N.right n)) x + +let rec findWithDefault n (x : key) def = + match N.toOpt n with + | None -> def + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findWithDefault (if x < v then (N.left n) else (N.right n)) x def + +let rec mem n (x : key)= + match N.toOpt n with + None -> false + | Some n (* Node(l, v, d, r, _) *) -> + let v = N.key n in + x = v || mem (if x < v then N.left n else N.right n) x + +let rec remove n (x : key) = + match N.toOpt n with + | None -> n + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let kr, vr = ref (N.key rn), ref (N.value rn) in + let r = N.removeMinAuxWithRef rn kr vr in + N.bal l !kr !vr r + else if x < v then + N.(bal (remove l x ) v (value n) r) + else + N.(bal l v (value n) (remove r x )) + +let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = + let l,v,d,r = N.(left n , key n, value n, right n) in + if x = v then (l, Some d, r) + else + if x < v then + match N.toOpt l with + | None -> + N.(empty , None, return n) + | Some l -> + let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) + else + match N.toOpt r with + | None -> + N.(return n, None, empty) + | Some r -> + let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) + + +let rec split (x : key) n = + match N.toOpt n with + None -> + N.(empty, None, empty) + | Some n -> + splitAux x n + +let rec merge s1 s2 f = + match N.(toOpt s1, toOpt s2) with + (None, None) -> N.empty + | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ + when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> + let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in + let (l2, d2, r2) = split v1 s2 in + N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) + | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> + let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in + let (l1, d1, r1) = split v2 s1 in + N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) + | _ -> + assert false + +let rec compareAux e1 e2 vcmp = + match e1,e2 with + | h1::t1, h2::t2 -> + let c = Pervasives.compare (N.key h1 : key) (N.key h2) in + if c = 0 then + let cx = vcmp (N.value h1) (N.value h2) [@bs] in + if cx = 0 then + compareAux + (N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + vcmp + else cx + else c + | _, _ -> 0 + +let cmp s1 s2 cmp = + let len1, len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + compareAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) + cmp + else if len1 < len2 then -1 + else 1 + + +let rec eqAux e1 e2 eq = + match e1,e2 with + | h1::t1, h2::t2 -> + if (N.key h1 : key) = (N.key h2) && + eq (N.value h1) (N.value h2) [@bs] then + eqAux ( + N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + eq + else false + | _, _ -> true (*end *) + +let eq s1 s2 eq = + let len1,len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + eqAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) eq + else false + +let rec addMutate (t : _ t) x data : _ t = + match N.toOpt t with + | None -> N.singleton0 x data + | Some nt -> + let k = N.key nt in + (* let c = (Bs_Cmp.getCmp cmp) x k [@bs] in *) + if x = k then begin + N.keySet nt x; + N.valueSet nt data; + N.return nt + end + else + let l, r = (N.left nt, N.right nt) in + (if x < k then + let ll = addMutate l x data in + N.leftSet nt ll + else + N.rightSet nt (addMutate r x data); + ); + N.return (N.balMutate nt) + +let ofArray (xs : (key * _) array) = + let len = A.length xs in + if len = 0 then N.empty0 + else + let next = + ref (S.strictlySortedLength xs + (fun[@bs] (x0,_) (y0,_) -> + x0 < y0 + )) + in + let result = ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next; + N.ofSortedArrayRevAux xs (!next - 1) (!next) + end + ) in + for i = !next to len - 1 do + let k, v = (A.unsafe_get xs i) in + result := addMutate !result k v + done ; + !result + + + + + diff --git a/jscomp/others/bs_internalSetInt.ml b/jscomp/others/bs_internalSetInt.ml index 15a000e5e9b..a962c604403 100644 --- a/jscomp/others/bs_internalSetInt.ml +++ b/jscomp/others/bs_internalSetInt.ml @@ -1,31 +1,15 @@ -# 4 "internal_set.cppo.ml" +# 5 "internal_set.cppo.ml" type elt = int +module S = Bs_SortInt -# 10 +# 12 module N = Bs_internalAVLset module A = Bs_Array type t = elt N.t0 -let rec add (t : t) (x : elt) : t = - match N.toOpt t with - None -> N.singleton0 x - | Some nt -> - let v = N.key nt in - if x = v then t else - let l, r = N.(left nt , right nt) in - if x < v then - let ll = add l x in - if ll == l then t - else N.bal ll v r - else - let rr = add r x in - if rr == r then t - else N.bal l v (add r x) - - let rec mem (t : t) (x : elt) = match N.toOpt t with @@ -34,29 +18,6 @@ let rec mem (t : t) (x : elt) = let v = N.key n in x = v || mem (if x < v then N.left n else N.right n) x -let rec remove (t : t) (x : elt) : t = - match N.toOpt t with - | None -> t - | Some n -> - let l,v,r = N.(left n, key n, right n) in - if x = v then - match N.toOpt l, N.toOpt r with - | None, _ -> r - | _, None -> l - | _, Some rn -> - let v = ref (N.key rn) in - let r = N.removeMinAuxWithRef rn v in - N.bal l !v r - else - if x < v then - let ll = remove l x in - if ll == l then t - else N.bal ll v r - else - let rr = remove r x in - if rr == r then t - else N.bal l v rr - let rec compareAux e1 e2 = match e1,e2 with @@ -136,22 +97,23 @@ let rec addMutate t (x : elt)= ); N.return (N.balMutate nt) -let rec sortedLengthAux (xs : elt array) prec acc len = - if acc >= len then acc - else - let v = A.unsafe_get xs acc in - if v > prec then - sortedLengthAux xs v (acc + 1) len - else acc let ofArray (xs : elt array) = let len = A.length xs in if len = 0 then N.empty else - let next = sortedLengthAux xs (A.unsafe_get xs 0) 1 len in - let result = ref (N.ofSortedArrayAux xs 0 next) in - for i = next to len - 1 do + let next = ref (S.strictlySortedLength xs ) in + let result = + ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next ; + N.ofSortedArrayRevAux xs (!next - 1) !next + end + ) in + for i = !next to len - 1 do result := addMutate !result (A.unsafe_get xs i) done ; !result diff --git a/jscomp/others/bs_internalSetString.ml b/jscomp/others/bs_internalSetString.ml index 1eae5a4c91c..189dbb2e1f9 100644 --- a/jscomp/others/bs_internalSetString.ml +++ b/jscomp/others/bs_internalSetString.ml @@ -1,31 +1,15 @@ # 2 "internal_set.cppo.ml" type elt = string +module S = Bs_SortString -# 10 +# 12 module N = Bs_internalAVLset module A = Bs_Array type t = elt N.t0 -let rec add (t : t) (x : elt) : t = - match N.toOpt t with - None -> N.singleton0 x - | Some nt -> - let v = N.key nt in - if x = v then t else - let l, r = N.(left nt , right nt) in - if x < v then - let ll = add l x in - if ll == l then t - else N.bal ll v r - else - let rr = add r x in - if rr == r then t - else N.bal l v (add r x) - - let rec mem (t : t) (x : elt) = match N.toOpt t with @@ -34,29 +18,6 @@ let rec mem (t : t) (x : elt) = let v = N.key n in x = v || mem (if x < v then N.left n else N.right n) x -let rec remove (t : t) (x : elt) : t = - match N.toOpt t with - | None -> t - | Some n -> - let l,v,r = N.(left n, key n, right n) in - if x = v then - match N.toOpt l, N.toOpt r with - | None, _ -> r - | _, None -> l - | _, Some rn -> - let v = ref (N.key rn) in - let r = N.removeMinAuxWithRef rn v in - N.bal l !v r - else - if x < v then - let ll = remove l x in - if ll == l then t - else N.bal ll v r - else - let rr = remove r x in - if rr == r then t - else N.bal l v rr - let rec compareAux e1 e2 = match e1,e2 with @@ -136,22 +97,23 @@ let rec addMutate t (x : elt)= ); N.return (N.balMutate nt) -let rec sortedLengthAux (xs : elt array) prec acc len = - if acc >= len then acc - else - let v = A.unsafe_get xs acc in - if v > prec then - sortedLengthAux xs v (acc + 1) len - else acc let ofArray (xs : elt array) = let len = A.length xs in if len = 0 then N.empty else - let next = sortedLengthAux xs (A.unsafe_get xs 0) 1 len in - let result = ref (N.ofSortedArrayAux xs 0 next) in - for i = next to len - 1 do + let next = ref (S.strictlySortedLength xs ) in + let result = + ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next ; + N.ofSortedArrayRevAux xs (!next - 1) !next + end + ) in + for i = !next to len - 1 do result := addMutate !result (A.unsafe_get xs i) done ; !result diff --git a/jscomp/others/internal_map.cppo.ml b/jscomp/others/internal_map.cppo.ml new file mode 100644 index 00000000000..a11bfa338c8 --- /dev/null +++ b/jscomp/others/internal_map.cppo.ml @@ -0,0 +1,223 @@ +#ifdef TYPE_STRING +type key = string +#elif defined TYPE_INT +type key = int +#else + [%error "unknown type"] +#endif + +module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort +type ('key, 'a, 'id) t0 = ('key,'a) N.t0 + +type 'a t = (key,'a) N.t0 + +let rec add t (x : key) (data : _) = + match N.toOpt t with + | None -> + N.singleton0 x data + | Some n -> + let k = N.key n in + if x = k then + N.updateKV n x data + else + let v = N.value n in + if x < k then + N.bal (add (N.left n) x data ) k v (N.right n) + else + N.bal (N.left n) k v (add (N.right n) x data ) + +let rec findOpt n (x : key) = + match N.toOpt n with + None -> None + | Some n -> + let v = N.key n in + if x = v then Some (N.value n) + else findOpt (if x < v then N.left n else N.right n) x + +let rec findNull n (x : key) = + match N.toOpt n with + | None -> + Js.null + | Some n -> + let v = N.key n in + if x = v then N.return (N.value n) + else findNull (if x < v then (N.left n) else (N.right n)) x + +let rec findExn n (x : key) = + match N.toOpt n with + | None -> [%assert "findExn"] + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findExn (if x < v then (N.left n) else (N.right n)) x + +let rec findWithDefault n (x : key) def = + match N.toOpt n with + | None -> def + | Some n -> + let v = N.key n in + if x = v then (N.value n) + else findWithDefault (if x < v then (N.left n) else (N.right n)) x def + +let rec mem n (x : key)= + match N.toOpt n with + None -> false + | Some n (* Node(l, v, d, r, _) *) -> + let v = N.key n in + x = v || mem (if x < v then N.left n else N.right n) x + +let rec remove n (x : key) = + match N.toOpt n with + | None -> n + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let kr, vr = ref (N.key rn), ref (N.value rn) in + let r = N.removeMinAuxWithRef rn kr vr in + N.bal l !kr !vr r + else if x < v then + N.(bal (remove l x ) v (value n) r) + else + N.(bal l v (value n) (remove r x )) + +let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = + let l,v,d,r = N.(left n , key n, value n, right n) in + if x = v then (l, Some d, r) + else + if x < v then + match N.toOpt l with + | None -> + N.(empty , None, return n) + | Some l -> + let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) + else + match N.toOpt r with + | None -> + N.(return n, None, empty) + | Some r -> + let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) + + +let rec split (x : key) n = + match N.toOpt n with + None -> + N.(empty, None, empty) + | Some n -> + splitAux x n + +let rec merge s1 s2 f = + match N.(toOpt s1, toOpt s2) with + (None, None) -> N.empty + | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ + when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> + let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in + let (l2, d2, r2) = split v1 s2 in + N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) + | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> + let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in + let (l1, d1, r1) = split v2 s1 in + N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) + | _ -> + assert false + +let rec compareAux e1 e2 vcmp = + match e1,e2 with + | h1::t1, h2::t2 -> + let c = Pervasives.compare (N.key h1 : key) (N.key h2) in + if c = 0 then + let cx = vcmp (N.value h1) (N.value h2) [@bs] in + if cx = 0 then + compareAux + (N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + vcmp + else cx + else c + | _, _ -> 0 + +let cmp s1 s2 cmp = + let len1, len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + compareAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) + cmp + else if len1 < len2 then -1 + else 1 + + +let rec eqAux e1 e2 eq = + match e1,e2 with + | h1::t1, h2::t2 -> + if (N.key h1 : key) = (N.key h2) && + eq (N.value h1) (N.value h2) [@bs] then + eqAux ( + N.stackAllLeft (N.right h1) t1 ) + (N.stackAllLeft (N.right h2) t2) + eq + else false + | _, _ -> true (*end *) + +let eq s1 s2 eq = + let len1,len2 = N.length0 s1, N.length0 s2 in + if len1 = len2 then + eqAux + (N.stackAllLeft s1 []) + (N.stackAllLeft s2 []) eq + else false + +let rec addMutate (t : _ t) x data : _ t = + match N.toOpt t with + | None -> N.singleton0 x data + | Some nt -> + let k = N.key nt in + (* let c = (Bs_Cmp.getCmp cmp) x k [@bs] in *) + if x = k then begin + N.keySet nt x; + N.valueSet nt data; + N.return nt + end + else + let l, r = (N.left nt, N.right nt) in + (if x < k then + let ll = addMutate l x data in + N.leftSet nt ll + else + N.rightSet nt (addMutate r x data); + ); + N.return (N.balMutate nt) + +let ofArray (xs : (key * _) array) = + let len = A.length xs in + if len = 0 then N.empty0 + else + let next = + ref (S.strictlySortedLength xs + (fun[@bs] (x0,_) (y0,_) -> + x0 < y0 + )) + in + let result = ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next; + N.ofSortedArrayRevAux xs (!next - 1) (!next) + end + ) in + for i = !next to len - 1 do + let k, v = (A.unsafe_get xs i) in + result := addMutate !result k v + done ; + !result + + + + + diff --git a/jscomp/others/internal_set.cppo.ml b/jscomp/others/internal_set.cppo.ml index f7375d2ff57..cae6c07745d 100644 --- a/jscomp/others/internal_set.cppo.ml +++ b/jscomp/others/internal_set.cppo.ml @@ -1,7 +1,9 @@ #ifdef TYPE_STRING type elt = string +module S = Bs_SortString #elif defined TYPE_INT type elt = int +module S = Bs_SortInt #else [%error "unknown type"] #endif @@ -13,23 +15,6 @@ module A = Bs_Array type t = elt N.t0 -let rec add (t : t) (x : elt) : t = - match N.toOpt t with - None -> N.singleton0 x - | Some nt -> - let v = N.key nt in - if x = v then t else - let l, r = N.(left nt , right nt) in - if x < v then - let ll = add l x in - if ll == l then t - else N.bal ll v r - else - let rr = add r x in - if rr == r then t - else N.bal l v (add r x) - - let rec mem (t : t) (x : elt) = match N.toOpt t with @@ -38,29 +23,6 @@ let rec mem (t : t) (x : elt) = let v = N.key n in x = v || mem (if x < v then N.left n else N.right n) x -let rec remove (t : t) (x : elt) : t = - match N.toOpt t with - | None -> t - | Some n -> - let l,v,r = N.(left n, key n, right n) in - if x = v then - match N.toOpt l, N.toOpt r with - | None, _ -> r - | _, None -> l - | _, Some rn -> - let v = ref (N.key rn) in - let r = N.removeMinAuxWithRef rn v in - N.bal l !v r - else - if x < v then - let ll = remove l x in - if ll == l then t - else N.bal ll v r - else - let rr = remove r x in - if rr == r then t - else N.bal l v rr - let rec compareAux e1 e2 = match e1,e2 with @@ -140,22 +102,23 @@ let rec addMutate t (x : elt)= ); N.return (N.balMutate nt) -let rec sortedLengthAux (xs : elt array) prec acc len = - if acc >= len then acc - else - let v = A.unsafe_get xs acc in - if v > prec then - sortedLengthAux xs v (acc + 1) len - else acc let ofArray (xs : elt array) = let len = A.length xs in if len = 0 then N.empty else - let next = sortedLengthAux xs (A.unsafe_get xs 0) 1 len in - let result = ref (N.ofSortedArrayAux xs 0 next) in - for i = next to len - 1 do + let next = ref (S.strictlySortedLength xs ) in + let result = + ref ( + if !next >= 0 then + N.ofSortedArrayAux xs 0 !next + else begin + next := - !next ; + N.ofSortedArrayRevAux xs (!next - 1) !next + end + ) in + for i = !next to len - 1 do result := addMutate !result (A.unsafe_get xs i) done ; !result diff --git a/jscomp/others/map.cppo.ml b/jscomp/others/map.cppo.ml index fb17cdab1d9..3c410cff6a2 100644 --- a/jscomp/others/map.cppo.ml +++ b/jscomp/others/map.cppo.ml @@ -1,82 +1,74 @@ #ifdef TYPE_STRING type key = string +module I = Bs_internalMapString #elif defined TYPE_INT type key = int +module I = Bs_internalMapInt #else [%error "unknown type"] #endif module N = Bs_internalAVLtree +module A = Bs_Array +module S = Bs_Sort -type ('key, 'a, 'id) t0 = ('key,'a) N.t0 - -type 'a t = (key,'a) N.t0 - - - - +type 'a t = (key, 'a) N.t0 let empty = N.empty0 let isEmpty = N.isEmpty0 let singleton = N.singleton0 -let minBinding = N.minKVOpt0 -let maxBinding = N.maxKVOpt0 +let minKVOpt = N.minKVOpt0 +let minKVNull = N.minKVNull0 +let maxKVOpt = N.maxKVOpt0 +let maxKVNull = N.maxKVNull0 let iter = N.iter0 let map = N.map0 let mapi = N.mapi0 let fold = N.fold0 let forAll = N.forAll0 let exists = N.exists0 -let filter = N.filter0 -let partition = N.partition0 +let filter = N.filterShared0 +let partition = N.partitionShared0 let length = N.length0 let toList = N.toList0 let checkInvariant = N.checkInvariant -let rec add t (x : key) (data : _) = +let rec update t (newK : key) (newD : _) = match N.toOpt t with | None -> - N.(return @@ node ~left:empty ~key:x ~value:data ~right:empty ~h:1) - | Some n (* Node(l, v, d, r, h) *) -> - let l,k,v,r = N.(left n, key n, value n, right n) in - if x = k then - N.(return @@ node ~left:l ~key:x ~value:data ~right:r ~h:(h n)) - else if x < k then - N.(bal (add l x data ) k v r) - else - N.(bal l k v (add r x data )) - -let rec findOpt (x : key) n = - match N.toOpt n with - None -> None + N.singleton0 newK newD | Some n -> - let v = N.key n in - if x = v then Some (N.value n) - else findOpt x (if x < v then N.left n else N.right n) - -let rec findAssert (x : key) n = - match N.toOpt n with - | None -> - [%assert "Not_found"] + let k = N.key n in + if newK = k then + N.updateKV n newK newD + else + let v = N.value n in + if newK < k then + N.bal (update (N.left n) newK newD) k v (N.right n) + else + N.bal (N.left n) k v (update (N.right n) newK newD) + +let rec updateWithOpt t (x : key) f = + match N.toOpt t with + | None -> + begin match f None [@bs] with + | None -> t + | Some data -> + N.singleton0 x data + end | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findAssert x (if x < v then (N.left n) else (N.right n)) - -let rec findWithDefault n (x : key) def = - match N.toOpt n with - | None -> def - | Some n -> - let v = N.key n in - if x = v then (N.value n) - else findWithDefault (if x < v then (N.left n) else (N.right n)) x def - -let rec mem n (x : key)= - match N.toOpt n with - None -> false - | Some n (* Node(l, v, d, r, _) *) -> - let v = N.key n in - x = v || mem (if x < v then N.left n else N.right n) x + let k = N.key n in + if x = k then + begin match f (Some k) [@bs] with + | None -> t + | Some data -> N.updateKV n x data + end + else + let v = N.value n in + if x < k then + N.bal (updateWithOpt (N.left n) x f) k v (N.right n) + else + N.bal (N.left n) k v (updateWithOpt (N.right n) x f) let rec remove n (x : key) = match N.toOpt n with @@ -96,100 +88,13 @@ let rec remove n (x : key) = else N.(bal l v (value n) (remove r x )) -let rec splitAux (x : key) (n : _ N.node) : _ t0 * _ option * _ t0 = - let l,v,d,r = N.(left n , key n, value n, right n) in - if x = v then (l, Some d, r) - else - if x < v then - match N.toOpt l with - | None -> - N.(empty , None, return n) - | Some l -> - let (ll, pres, rl) = splitAux x l in (ll, pres, N.join rl v d r) - else - match N.toOpt r with - | None -> - N.(return n, None, empty) - | Some r -> - let (lr, pres, rr) = splitAux x r in (N.join l v d lr, pres, rr) - - -let rec split (x : key) n = - match N.toOpt n with - None -> - N.(empty, None, empty) - | Some n -> - splitAux x n - -let rec merge s1 s2 f = - match N.(toOpt s1, toOpt s2) with - (None, None) -> N.empty - | Some n (* (Node (l1, v1, d1, r1, h1), _)*), _ - when N.(h n >= (match N.toOpt s2 with None -> 0 | Some n -> N.h n)) -> - let (l1,v1,d1,r1) = N.(left n, key n, value n, right n ) in - let (l2, d2, r2) = split v1 s2 in - N.concatOrJoin (merge l1 l2 f) v1 (f v1 (Some d1) d2 [@bs]) (merge r1 r2 f) - | (_, Some n) (* Node (l2, v2, d2, r2, h2) *) -> - let (l2, v2, d2, r2) = N.(left n, key n, value n, right n) in - let (l1, d1, r1) = split v2 s1 in - N.concatOrJoin (merge l1 l2 f) v2 (f v2 d1 (Some d2) [@bs]) (merge r1 r2 f) - | _ -> - assert false - -let rec compareAux e1 e2 vcmp = - match e1,e2 with - | h1::t1, h2::t2 -> - let c = Pervasives.compare (N.key h1 : key) (N.key h2) in - if c = 0 then - let cx = vcmp (N.value h1) (N.value h2) [@bs] in - if cx = 0 then - compareAux - (N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - vcmp - else cx - else c - | _, _ -> 0 - -let cmp s1 s2 cmp = - let len1, len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - compareAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) - cmp - else if len1 < len2 then -1 - else 1 - - -let rec eqAux e1 e2 eq = - match e1,e2 with - | h1::t1, h2::t2 -> - if (N.key h1 : key) = (N.key h2) && - eq (N.value h1) (N.value h2) [@bs] then - eqAux ( - N.stackAllLeft (N.right h1) t1 ) - (N.stackAllLeft (N.right h2) t2) - eq - else false - | _, _ -> true (*end *) - -let eq s1 s2 eq = - let len1,len2 = N.length0 s1, N.length0 s2 in - if len1 = len2 then - eqAux - (N.stackAllLeft s1 []) - (N.stackAllLeft s2 []) eq - else false - -let ofArray (xs : _ array) : _ t0 = - let result = ref N.empty in - for i = 0 to Array.length xs - 1 do - let k, v = (Bs_Array.unsafe_get xs i) in - result := add !result k v - done ; - !result - - - - +let mem = I.mem +let cmp = I.cmp +let eq = I.eq +let findOpt = I.findOpt +let findNull = I.findNull +let findWithDefault = I.findWithDefault +let findExn = I.findExn +let split = I.split +let merge = I.merge +let ofArray = I.ofArray \ No newline at end of file diff --git a/jscomp/others/map.cppo.mli b/jscomp/others/map.cppo.mli index 81b9dae6ec7..ca6978c9510 100644 --- a/jscomp/others/map.cppo.mli +++ b/jscomp/others/map.cppo.mli @@ -9,19 +9,22 @@ type 'a t (** The type of maps from type [key] to type ['a]. *) val empty: 'a t -(** The empty map. *) val ofArray: (key * 'a) array -> 'a t val isEmpty: 'a t -> bool -(** Test whether a map is empty or not. *) val mem: 'a t -> key -> bool -val add: 'a t -> key -> 'a -> 'a t +val update: 'a t -> key -> 'a -> 'a t (** [add m x y] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound in [m], its previous binding disappears. *) +val updateWithOpt: + 'a t -> + key -> + (key option -> 'a option [@bs]) -> + 'a t val singleton: key -> 'a -> 'a t @@ -89,14 +92,11 @@ val toList: 'a t -> (key * 'a) list given to {!Map.Make}. *) -val minBinding: 'a t -> (key * 'a) option -(** Return the smallest binding of the given map - or raise - *) +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null -val maxBinding: 'a t -> (key * 'a) option -(** returns the largest binding of the given map. - *) @@ -110,13 +110,10 @@ val split: key -> 'a t -> 'a t * 'a option * 'a t or [Some v] if [m] binds [v] to [x]. *) -val findOpt: key -> 'a t -> 'a option -(** [findOpt x m] returns the current binding of [x] in [m] *) - -val findAssert: key -> 'a t -> 'a -(** raise an exception if not there *) - +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn: 'a t -> key -> 'a val map: 'a t -> ('a -> 'b [@bs]) -> 'b t (** [map m f] returns a map with same domain as [m], where the diff --git a/jscomp/others/mapm.cppo.ml b/jscomp/others/mapm.cppo.ml new file mode 100644 index 00000000000..68c717f9c56 --- /dev/null +++ b/jscomp/others/mapm.cppo.ml @@ -0,0 +1,114 @@ +#ifdef TYPE_INT +module I = Bs_internalMapInt +module S = Bs_SortInt +type key = int +#elif defined TYPE_STRING +module I = Bs_internalMapString +module S = Bs_SortString +type key = string +#else + [%error "unknown type"] +#endif +module N = Bs_internalAVLtree +module A = Bs_Array + + + + +type 'a t = { + mutable data : 'a I.t +} [@@bs.deriving abstract] + + +let empty () = t ~data:N.empty0 +let isEmpty m = N.isEmpty0 (data m) +let singleton k v = t ~data:(N.singleton0 k v) +let minKVOpt m = N.minKVOpt0 (data m) +let minKVNull m = N.minKVNull0 (data m) +let maxKVOpt m = N.maxKVOpt0 (data m) +let maxKVNull m = N.maxKVNull0 (data m) + +let addOnly (m : _ t) k v = + let old_data = data m in + let v = I.addMutate old_data k v in + if v != old_data then + dataSet m v + +let add (d : 'a t) (k : key) (v : 'a) : 'a t= + addOnly d k v; + d +let iter d f = N.iter0 (data d) f +let map d f = t ~data:(N.map0 (data d) f) +let mapi d f = t ~data:(N.mapi0 (data d) f) +let fold d acc f = N.fold0 (data d) acc f +let forAll d f = N.forAll0 (data d) f +let exists d f = N.exists0 (data d) f + +let length d = N.length0 (data d) +let toList d = N.toList0 (data d) +let checkInvariant d = N.checkInvariant (data d) +let mem d v = I.mem (data d) v + + +let rec removeMutateAux nt (x : key)= + let k = N.key nt in + if x = k then + let l,r = N.(left nt, right nt) in + match N.(toOpt l, toOpt r) with + | Some _, Some nr -> + N.rightSet nt (N.removeMinAuxWithRootMutate nt nr); + N.return (N.balMutate nt) + | None, Some _ -> + r + | (Some _ | None ), None -> l + else + begin + if x < k then + match N.toOpt (N.left nt) with + | None -> N.return nt + | Some l -> + N.leftSet nt (removeMutateAux l x ); + N.return (N.balMutate nt) + else + match N.toOpt (N.right nt) with + | None -> N.return nt + | Some r -> + N.rightSet nt (removeMutateAux r x); + N.return (N.balMutate nt) + end +let removeMutate nt x = + match N.toOpt nt with + | None -> nt + | Some nt -> removeMutateAux nt x + +let removeOnly d v = + let old_data = data d in + let v = removeMutate old_data v in + if v != old_data then + dataSet d v + +let remove d v = + removeOnly d v; + d + + +let cmp = I.cmp +let eq = I.eq + + +(* let split = I.split *) +(* let merge = I.merge *) + + +let ofArray xs = + t ~data:(I.ofArray xs) + +let cmp d0 d1 = + I.cmp (data d0) (data d1) +let eq d0 d1 = + I.eq (data d0) (data d1) +let findOpt d x = + I.findOpt (data d) x +let findNull d x = I.findNull (data d) x +let findWithDefault d x def = I.findWithDefault (data d) x def +let findExn d x = I.findExn (data d) x \ No newline at end of file diff --git a/jscomp/others/mapm.cppo.mli b/jscomp/others/mapm.cppo.mli new file mode 100644 index 00000000000..530ebd0b1ff --- /dev/null +++ b/jscomp/others/mapm.cppo.mli @@ -0,0 +1,124 @@ +#ifdef TYPE_STRING +type key = string +#elif defined TYPE_INT +type key = int +#else +[%error "unknown type"] +#endif +type 'a t + + +val empty: unit -> 'a t + +val ofArray: (key * 'a) array -> 'a t + +val isEmpty: 'a t -> bool + +val mem: 'a t -> key -> bool + +val addOnly : 'a t -> key -> 'a -> unit +val add: 'a t -> key -> 'a -> 'a t +(** [add m x y] do the in-place modification, return + [m] for chaining. If [x] was already bound + in [m], its previous binding disappears. *) + +val singleton: key -> 'a -> 'a t + +val remove: 'a t -> key -> 'a t +(** [remove m x] do the in-place modification, return [m] for chaining *) + +(* val merge: + 'a t -> 'b t -> + (key -> 'a option -> 'b option -> 'c option [@bs]) -> + 'c t *) +(** [merge m1 m2 f] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + *) + +val cmp: 'a t -> 'a t -> ('a -> 'a -> int [@bs]) -> int + +val eq: 'a t -> 'a t -> ('a -> 'a -> bool [@bs]) -> bool +(** [equal m1 m2 cmp] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + +val iter: 'a t -> (key -> 'a -> unit [@bs]) -> unit +(** [iter m f] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. *) + +val fold: 'a t -> 'b -> ('b -> key -> 'a -> 'b [@bs]) -> 'b +(** [fold m a f] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val forAll: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [forAll m p] checks if all the bindings of the map + satisfy the predicate [p]. + *) + +val exists: 'a t -> (key -> 'a -> bool [@bs]) -> bool +(** [exists m p] checks if at least one binding of the map + satisfy the predicate [p]. + *) + +(* val filter: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t *) +(** [filter m p] returns the map with all the bindings in [m] + that satisfy predicate [p]. +*) + + +(* val partition: (key -> 'a -> bool [@bs]) -> 'a t -> 'a t * 'a t *) +(** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + *) + +val length: 'a t -> int + + +val toList: 'a t -> (key * 'a) list +(** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Map.Make}. + *) + +val minKVOpt: 'a t -> (key * 'a) option +val minKVNull: 'a t -> (key * 'a) Js.null +val maxKVOpt: 'a t -> (key * 'a) option +val maxKVNull: 'a t -> (key * 'a) Js.null + + + + +(* val split: key -> 'a t -> 'a t * 'a option * 'a t *) +(** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + *) + +val findOpt: 'a t -> key -> 'a option +val findNull: 'a t -> key -> 'a Js.null +val findWithDefault: 'a t -> key -> 'a -> 'a +val findExn : 'a t -> key -> 'a + +val map: 'a t -> ('a -> 'b [@bs]) -> 'b t +(** [map m f] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: 'a t -> (key -> 'a -> 'b [@bs]) -> 'b t + + +val checkInvariant : _ t -> bool diff --git a/jscomp/others/set.cppo.ml b/jscomp/others/set.cppo.ml index c1a71412abe..605a66441b1 100644 --- a/jscomp/others/set.cppo.ml +++ b/jscomp/others/set.cppo.ml @@ -31,13 +31,48 @@ let toArray = N.toArray0 let ofSortedArrayUnsafe = N.ofSortedArrayUnsafe0 let checkInvariant = N.checkInvariant -let add = I.add +let rec add (t : t) (x : elt) : t = + match N.toOpt t with + None -> N.singleton0 x + | Some nt -> + let v = N.key nt in + if x = v then t else + let l, r = N.(left nt , right nt) in + if x < v then + let ll = add l x in + if ll == l then t + else N.bal ll v r + else + let rr = add r x in + if rr == r then t + else N.bal l v (add r x) +let rec remove (t : t) (x : elt) : t = + match N.toOpt t with + | None -> t + | Some n -> + let l,v,r = N.(left n, key n, right n) in + if x = v then + match N.toOpt l, N.toOpt r with + | None, _ -> r + | _, None -> l + | _, Some rn -> + let v = ref (N.key rn) in + let r = N.removeMinAuxWithRef rn v in + N.bal l !v r + else + if x < v then + let ll = remove l x in + if ll == l then t + else N.bal ll v r + else + let rr = remove r x in + if rr == r then t + else N.bal l v rr let ofArray = I.ofArray let cmp = I.cmp let eq = I.eq let findOpt = I.findOpt let subset = I.subset -let remove = I.remove let mem = I.mem let rec splitAuxNoPivot (n : _ N.node) (x : elt) : t * t = @@ -97,7 +132,7 @@ let rec union (s1 : t) (s2 : t) = | Some n1, Some n2 (* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) *) -> let h1, h2 = N.(h n1 , h n2) in if h1 >= h2 then - if h2 = 1 then I.add s1 (N.key n2) else begin + if h2 = 1 then add s1 (N.key n2) else begin let l1, v1, r1 = N.(left n1, key n1, right n1) in let (l2, r2) = splitAuxNoPivot n2 v1 in N.joinShared (union l1 l2) v1 (union r1 r2) diff --git a/jscomp/others/setm.cppo.mli b/jscomp/others/setm.cppo.mli index b1809815394..8bb6925480d 100644 --- a/jscomp/others/setm.cppo.mli +++ b/jscomp/others/setm.cppo.mli @@ -10,8 +10,10 @@ type t val empty: unit -> t val isEmpty: t -> bool val mem: t -> elt -> bool -val add: t -> elt -> t + val addOnly: t -> elt -> unit +val add: t -> elt -> t + val singleton: elt -> t val remove: t -> elt -> t val removeOnly: t -> elt -> unit diff --git a/jscomp/others/sort.cppo.ml b/jscomp/others/sort.cppo.ml index a54fe61549a..d80ee47f47c 100644 --- a/jscomp/others/sort.cppo.ml +++ b/jscomp/others/sort.cppo.ml @@ -8,6 +8,34 @@ type elt = string module A = Bs_Array +let rec sortedLengthAuxMore (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec > v then + sortedLengthAuxMore xs v (acc + 1) len + else acc + +let rec sortedLengthAuxLess (xs : elt array) prec acc len = + if acc >= len then acc + else + let v = A.unsafe_get xs acc in + if prec < v then + sortedLengthAuxLess xs v (acc + 1) len + else acc + +let strictlySortedLength (xs : elt array) = + let len = A.length xs in + match len with + | 0 | 1 -> len + | _ -> + let x0, x1 = A.unsafe_get xs 0, A.unsafe_get xs 1 in + (* let c = cmp x0 x1 [@bs] in *) + if x0 < x1 then + sortedLengthAuxLess xs x1 2 len + else if x0 > x1 then + - (sortedLengthAuxMore xs x1 2 len) + else 1 let rec isSortedAux (a : elt array) i last_bound = (* when [i = len - 1], it reaches the last element*) diff --git a/jscomp/others/sort.cppo.mli b/jscomp/others/sort.cppo.mli index 82269d0ac3b..556b37ca768 100644 --- a/jscomp/others/sort.cppo.mli +++ b/jscomp/others/sort.cppo.mli @@ -6,6 +6,14 @@ type elt = string [%error "unknown type"] #endif +val strictlySortedLength : + elt array -> + int +(** + [strictlySortedLenght xs] + return [+n] means increasing order + [-n] means negative order +*) val isSorted : elt array -> bool (** strictly sorted *) diff --git a/jscomp/runtime/js_null.ml b/jscomp/runtime/js_null.ml index 38168d6973d..2c0045fe0c3 100644 --- a/jscomp/runtime/js_null.ml +++ b/jscomp/runtime/js_null.ml @@ -31,11 +31,11 @@ external toOption : 'a t -> 'a option = "#null_to_opt" external return : 'a -> 'a t = "%identity" external test : 'a t -> bool = "#is_nil" external empty : 'a t = "#null" -external castUnsafe : 'a t -> 'a = "%identity" +external getUnsafe : 'a t -> 'a = "%identity" -let castExn f = +let getExn f = match toOption f with - | None -> Js_exn.raiseError "Js.Null.castExn" + | None -> Js_exn.raiseError "Js.Null.getExn" | Some x -> x let bind x f = diff --git a/jscomp/runtime/js_null.mli b/jscomp/runtime/js_null.mli index 9c34b790903..1455a435b32 100644 --- a/jscomp/runtime/js_null.mli +++ b/jscomp/runtime/js_null.mli @@ -38,9 +38,9 @@ external test : 'a t -> bool = "#is_nil" external empty : 'a t = "#null" -external castUnsafe : 'a t -> 'a = "%identity" +external getUnsafe : 'a t -> 'a = "%identity" -val castExn : 'a t -> 'a +val getExn : 'a t -> 'a (** Maps the contained value using the given function diff --git a/jscomp/stdlib/camlinternalOO.ml b/jscomp/stdlib/camlinternalOO.ml index 2c5f4e3f249..2c44867ab57 100644 --- a/jscomp/stdlib/camlinternalOO.ml +++ b/jscomp/stdlib/camlinternalOO.ml @@ -185,13 +185,13 @@ let new_method table = let get_method_label table name = #if BS then - match Meths.findOpt name table.methods_by_name + match Js.nullToOption (Meths.findNull table.methods_by_name name) with | Some x -> x | None -> let label = new_method table in - table.methods_by_name <- Meths.add table.methods_by_name name label; - table.methods_by_label <- Labs.add table.methods_by_label label true; + table.methods_by_name <- Meths.update table.methods_by_name name label; + table.methods_by_label <- Labs.update table.methods_by_label label true; label #else try @@ -208,7 +208,13 @@ let get_method_labels table names = let set_method table label element = incr method_count; - if Labs.findAssert label table.methods_by_label then + if +#if BS then + Labs.findExn table.methods_by_label label +#else + Labs.find label table.methods_by_label +#end + then put table label element else table.hidden_meths <- (label, element) :: table.hidden_meths @@ -234,7 +240,7 @@ let narrow table vars virt_meths concr_meths = #if BS then Vars.fold table.vars Vars.empty (fun[@bs] tvars lab info -> - if List.mem lab vars then Vars.add tvars lab info else tvars); + if List.mem lab vars then Vars.update tvars lab info else tvars); #else Vars.fold (fun[@bs] lab info tvars -> @@ -245,15 +251,15 @@ let narrow table vars virt_meths concr_meths = let by_label = ref Labs.empty in #if BS then List.iter2 (fun met label -> - by_name := Meths.add !by_name met label; + by_name := Meths.update !by_name met label; by_label := - Labs.add !by_label label + Labs.update !by_label label (Labs.findWithDefault table.methods_by_label label true) ) concr_meths concr_meth_labs; List.iter2 (fun met label -> - by_name := Meths.add !by_name met label; - by_label := Labs.add !by_label label false; + by_name := Meths.update !by_name met label; + by_label := Labs.update !by_label label false; ) virt_meths virt_meth_labs; #else List.iter2 @@ -287,7 +293,7 @@ let widen table = table.vars <- List.fold_left #if BS then - (fun s v -> Vars.add s v (Vars.findAssert v table.vars)) + (fun s v -> Vars.update s v (Vars.findExn table.vars v)) #else (fun s v -> Vars.add v (Vars.find v table.vars) s) #end @@ -308,11 +314,11 @@ let new_slot table = let new_variable table name = #if BS then - match Vars.findOpt name table.vars with + match Js.nullToOption (Vars.findNull table.vars name : int Js.null) with | Some x -> x | None -> let index = new_slot table in - if name <> "" then table.vars <- Vars.add table.vars name index ; + if name <> "" then table.vars <- Vars.update table.vars name index ; index #else try Vars.find name table.vars @@ -339,7 +345,7 @@ let new_methods_variables table meths vals = let get_variable table name = #if BS then - Vars.findAssert name table.vars + Vars.findExn table.vars name #else try Vars.find name table.vars with Not_found -> assert false #end @@ -369,8 +375,8 @@ let create_table public_methods = (fun i met -> let lab = i*2+2 in #if BS then - table.methods_by_name <- Meths.add table.methods_by_name met lab ; - table.methods_by_label <- Labs.add table.methods_by_label lab true + table.methods_by_name <- Meths.update table.methods_by_name met lab ; + table.methods_by_label <- Labs.update table.methods_by_label lab true #else table.methods_by_name <- Meths.add met lab table.methods_by_name; table.methods_by_label <- Labs.add lab true table.methods_by_label diff --git a/jscomp/test/.depend b/jscomp/test/.depend index 19c4b9169dc..870da80a8a2 100644 --- a/jscomp/test/.depend +++ b/jscomp/test/.depend @@ -61,7 +61,7 @@ arith_parser.cmj : ../stdlib/parsing.cmj ../stdlib/obj.cmj \ ../stdlib/lexing.cmj arith_syntax.cmj arith_syntax.cmj : arity_deopt.cmj : mt.cmj -array_data_util.cmj : ../others/bs.cmj ../stdlib/array.cmj +array_data_util.cmj : ../others/bs_Array.cmj array_safe_get.cmj : ../stdlib/array.cmj array_subtle_test.cmj : mt.cmj ../runtime/js.cmj ../stdlib/array.cmj array_test.cmj : ../stdlib/pervasives.cmj mt.cmj ../stdlib/list.cmj \ @@ -99,11 +99,14 @@ bs_ignore_effect.cmj : mt.cmj bs_ignore_test.cmj : ../runtime/js.cmj bs_list_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs.cmj bs_map_int_test.cmj : mt.cmj ../others/bs.cmj -bs_map_test.cmj : ../runtime/js.cmj ../others/bs.cmj +bs_map_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs_Array.cmj \ + ../others/bs.cmj array_data_util.cmj bs_min_max_test.cmj : ../stdlib/pervasives.cmj mt.cmj bs_mutable_set_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs.cmj \ array_data_util.cmj ../stdlib/array.cmj bs_node_string_buffer_test.cmj : ../others/node.cmj ../runtime/js.cmj +bs_poly_map_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs_Array.cmj \ + ../others/bs.cmj array_data_util.cmj bs_poly_mutable_set_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs.cmj \ array_data_util.cmj bs_poly_set_test.cmj : mt.cmj ../runtime/js.cmj ../others/bs.cmj \ @@ -114,7 +117,8 @@ bs_rbset_int_bench.cmj : rbset.cmj bs_rest_test.cmj : bs_set_bench.cmj : ../others/bs.cmj bs_set_int_test.cmj : mt.cmj ../stdlib/list.cmj ../runtime/js.cmj \ - ../others/bs.cmj array_data_util.cmj ../stdlib/array.cmj + ../others/bs_Array.cmj ../others/bs.cmj array_data_util.cmj \ + ../stdlib/array.cmj bs_sort_test.cmj : mt.cmj ../others/bs_Range.cmj ../others/bs_Array.cmj \ ../others/bs.cmj array_data_util.cmj bs_splice_partial.cmj : ../runtime/js.cmj diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile index 1cabd2b0f32..5618c033de4 100644 --- a/jscomp/test/Makefile +++ b/jscomp/test/Makefile @@ -234,6 +234,7 @@ OTHERS := test_literals a test_ari test_export2 test_internalOO test_obj_simple_ bs_poly_mutable_set_test\ bs_poly_set_test\ bs_stack_test\ + bs_poly_map_test\ # bs_uncurry_test # needs Lam to get rid of Uncurry arity first # simple_derive_test diff --git a/jscomp/test/array_data_util.js b/jscomp/test/array_data_util.js index 817c11f177b..ce5da2d19c1 100644 --- a/jscomp/test/array_data_util.js +++ b/jscomp/test/array_data_util.js @@ -1,22 +1,22 @@ 'use strict'; -var $$Array = require("../../lib/js/array.js"); var Bs_Array = require("../../lib/js/bs_Array.js"); function range(i, j) { - return $$Array.init((j - i | 0) + 1 | 0, (function (k) { + return Bs_Array.init((j - i | 0) + 1 | 0, (function (k) { return k + i | 0; })); } function randomRange(i, j) { - var v = Bs_Array.init((j - i | 0) + 1 | 0, (function (k) { - return k + i | 0; - })); - Bs_Array.shuffleInPlace(v); - return v; + return Bs_Array.shuffle(Bs_Array.init((j - i | 0) + 1 | 0, (function (k) { + return k + i | 0; + }))); } +var A = 0; + +exports.A = A; exports.range = range; exports.randomRange = randomRange; /* No side effect */ diff --git a/jscomp/test/array_data_util.ml b/jscomp/test/array_data_util.ml index b3e0d016cc5..64fea01d961 100644 --- a/jscomp/test/array_data_util.ml +++ b/jscomp/test/array_data_util.ml @@ -1,9 +1,11 @@ +module A = Bs_Array + (* []*) let range i j = - Array.init (j - i + 1) (fun k -> k + i ) + A.init (j - i + 1) (fun[@bs] k -> k + i ) let randomRange i j = - let v = Bs.Array.init (j - i + 1) (fun[@bs] k -> k + i ) in - Bs.Array.shuffleInPlace v ; - v \ No newline at end of file + A.shuffle (A.init (j - i + 1) (fun[@bs] k -> k + i )) + + \ No newline at end of file diff --git a/jscomp/test/bs_MapInt_test.js b/jscomp/test/bs_MapInt_test.js index fa7eb164724..e7302cc7bb6 100644 --- a/jscomp/test/bs_MapInt_test.js +++ b/jscomp/test/bs_MapInt_test.js @@ -13,10 +13,10 @@ function should(b) { function test() { var m = Bs_MapInt.empty; for(var i = 0; i <= 999999; ++i){ - m = Bs_MapInt.add(m, i, i); + m = Bs_MapInt.update(m, i, i); } for(var i$1 = 0; i$1 <= 999999; ++i$1){ - should(+(Bs_MapInt.findOpt(i$1, m) !== /* None */0)); + should(+(Bs_MapInt.findOpt(m, i$1) !== /* None */0)); } for(var i$2 = 0; i$2 <= 999999; ++i$2){ m = Bs_MapInt.remove(m, i$2); diff --git a/jscomp/test/bs_MapInt_test.ml b/jscomp/test/bs_MapInt_test.ml index 3f48960a9ad..e86f01330cf 100644 --- a/jscomp/test/bs_MapInt_test.ml +++ b/jscomp/test/bs_MapInt_test.ml @@ -4,10 +4,10 @@ let test () = let m = ref Bs.MapInt.empty in let count = 100_0000 - 1 in for i = 0 to count do - m := Bs.MapInt.add !m i i + m := Bs.MapInt.update !m i i done; for i = 0 to count do - should (Bs.MapInt.findOpt i !m <> None) + should (Bs.MapInt.findOpt !m i <> None) done; for i = 0 to count do m := Bs.MapInt.remove !m i ; diff --git a/jscomp/test/bs_array_test.js b/jscomp/test/bs_array_test.js index 8ac75171315..27003466dd8 100644 --- a/jscomp/test/bs_array_test.js +++ b/jscomp/test/bs_array_test.js @@ -178,7 +178,7 @@ var v = Bs_Array.init(3000, (function (i) { var u = Bs_Array.copy(v); -Bs_Array.shuffleInPlace(u); +Bs_Array.shuffleOnly(u); neq("File \"bs_array_test.ml\", line 63, characters 6-13", u, v); diff --git a/jscomp/test/bs_array_test.ml b/jscomp/test/bs_array_test.ml index c1b1ce0256d..20207696dec 100644 --- a/jscomp/test/bs_array_test.ml +++ b/jscomp/test/bs_array_test.ml @@ -59,7 +59,7 @@ let add = fun [@bs] x y -> x + y let () = let v = Bs.Array.init 3000 (fun[@bs] i -> i) in let u = Bs.Array.copy v in - Bs.Array.shuffleInPlace u ; + Bs.Array.shuffleOnly u ; neq __LOC__ u v (* unlikely*); let sum x = Bs.Array.foldLeft x 0 add in eq __LOC__ ( sum u) (sum v) diff --git a/jscomp/test/bs_hashtbl_string_test.js b/jscomp/test/bs_hashtbl_string_test.js index 4a250a666b4..ea4f08b8149 100644 --- a/jscomp/test/bs_hashtbl_string_test.js +++ b/jscomp/test/bs_hashtbl_string_test.js @@ -146,10 +146,10 @@ function bench3(m) { var cmp = m[/* cmp */0]; var table = empty.data; for(var i = 0; i <= 1000000; ++i){ - table = Bs_Map.add0(table, "" + i, i, cmp); + table = Bs_Map.update0(table, "" + i, i, cmp); } for(var i$1 = 0; i$1 <= 1000000; ++i$1){ - if (!Bs_Map.mem0("" + i$1, table, cmp)) { + if (!Bs_Map.mem0(table, "" + i$1, cmp)) { throw [ Caml_builtin_exceptions.assert_failure, [ diff --git a/jscomp/test/bs_hashtbl_string_test.ml b/jscomp/test/bs_hashtbl_string_test.ml index 617cce4b400..aa7b3e60355 100644 --- a/jscomp/test/bs_hashtbl_string_test.ml +++ b/jscomp/test/bs_hashtbl_string_test.ml @@ -89,13 +89,13 @@ let bench3 (type t) (m : (string,t) Bs.Cmp.t) = let cmp = String.cmp in let table = ref (B.data empty) in for i = 0 to count do - table := Bs.Map.add0 ~cmp !table + table := Bs.Map.update0 ~cmp !table (string_of_int i) i done ; for i = 0 to count do assert (Bs.Map.mem0 ~cmp - - (string_of_int i) !table) + !table + (string_of_int i) ) done; for i = 0 to count do table := Bs.Map.remove0 ~cmp !table (string_of_int i) diff --git a/jscomp/test/bs_map_int_test.js b/jscomp/test/bs_map_int_test.js index 6fa3f48cf7a..2e6297feec8 100644 --- a/jscomp/test/bs_map_int_test.js +++ b/jscomp/test/bs_map_int_test.js @@ -40,14 +40,12 @@ function b(loc, v) { return /* () */0; } -var v = Bs_Array.init(1000000, (function (i) { - return /* tuple */[ - i, - i - ]; - })); - -Bs_Array.shuffleInPlace(v); +var v = Bs_Array.shuffle(Bs_Array.init(1000000, (function (i) { + return /* tuple */[ + i, + i + ]; + }))); var u = Bs_MapInt.ofArray(v); @@ -65,9 +63,12 @@ Mt.from_pair_suites("bs_map_int_test.ml", suites[0]); var N = 0; +var A = 0; + exports.suites = suites; exports.test_id = test_id; exports.eq = eq; exports.b = b; exports.N = N; +exports.A = A; /* v Not a pure module */ diff --git a/jscomp/test/bs_map_int_test.ml b/jscomp/test/bs_map_int_test.ml index bb22395df36..ae459117913 100644 --- a/jscomp/test/bs_map_int_test.ml +++ b/jscomp/test/bs_map_int_test.ml @@ -12,10 +12,10 @@ let b loc v = (fun _ -> Mt.Ok v)) :: !suites module N = Bs.MapInt - +module A = Bs.Array let () = - let v = Bs.Array.init 1_000_000 (fun[@bs] i -> (i,i)) in - Bs.Array.shuffleInPlace v ; + let v = + A.shuffle (A.init 1_000_000 (fun[@bs] i -> (i,i))) in let u = N.ofArray v in b __LOC__ (N.checkInvariant u); let firstHalf = Bs.Array.sub v 0 2_000 in diff --git a/jscomp/test/bs_map_test.js b/jscomp/test/bs_map_test.js index 6e62a7da064..1ece4acedea 100644 --- a/jscomp/test/bs_map_test.js +++ b/jscomp/test/bs_map_test.js @@ -1,22 +1,38 @@ 'use strict'; +var Mt = require("./mt.js"); var Bs_Map = require("../../lib/js/bs_Map.js"); var Bs_Set = require("../../lib/js/bs_Set.js"); +var Bs_List = require("../../lib/js/bs_List.js"); +var Bs_Array = require("../../lib/js/bs_Array.js"); var Bs_MapInt = require("../../lib/js/bs_MapInt.js"); var Caml_primitive = require("../../lib/js/caml_primitive.js"); +var Array_data_util = require("./array_data_util.js"); var Bs_internalAVLset = require("../../lib/js/bs_internalAVLset.js"); var Bs_internalAVLtree = require("../../lib/js/bs_internalAVLtree.js"); -var N = /* module */[/* cmp */Caml_primitive.caml_int_compare]; +var suites = [/* [] */0]; -var m0 = { - dict: N, - data: Bs_internalAVLtree.empty0 -}; +var test_id = [0]; + +function eq(loc, x, y) { + return Mt.eq_suites(test_id, suites, loc, x, y); +} + +function b(loc, v) { + return Mt.bool_suites(test_id, suites, loc, v); +} + +var Icmp = /* module */[/* cmp */Caml_primitive.caml_int_compare]; var cmp = Caml_primitive.caml_int_compare; -var I = /* module */[/* cmp */cmp]; +var Icmp2 = /* module */[/* cmp */cmp]; + +var m0 = { + dict: Icmp, + data: Bs_internalAVLtree.empty0 +}; function cmp$1(x, y) { return Caml_primitive.caml_int_compare(y, x); @@ -25,7 +41,7 @@ function cmp$1(x, y) { var I2 = /* module */[/* cmp */cmp$1]; var m = { - dict: I, + dict: Icmp2, data: Bs_internalAVLtree.empty0 }; @@ -41,7 +57,7 @@ m2.dict; var m_dict = m.dict; for(var i = 0; i <= 100000; ++i){ - data = Bs_Map.add0(data, i, i, m_dict[/* cmp */0]); + data = Bs_Map.update0(data, i, i, m_dict[/* cmp */0]); } var newm = { @@ -51,12 +67,12 @@ var newm = { console.log(newm); -var m11 = Bs_Map.add0(Bs_Map.empty0, 1, 1, cmp); +var m11 = Bs_Map.update0(Bs_Map.empty0, 1, 1, Icmp[/* cmp */0]); console.log(m11); var v = { - dict: I, + dict: Icmp2, data: Bs_internalAVLset.empty0 }; @@ -67,33 +83,113 @@ var cmp$2 = m_dict$1[/* cmp */0]; var data$1 = v.data; for(var i$1 = 0; i$1 <= 100000; ++i$1){ - data$1 = Bs_Set.add0(cmp$2, data$1, i$1); + data$1 = Bs_Set.add0(data$1, i$1, cmp$2); } console.log(data$1); +function f(param) { + return Bs_Map.ofArray(Icmp, param); +} + +function $eq$tilde(a, b) { + return (function (param) { + return Bs_Map.eq(a, b, param); + }); +} + +var u0 = f(Bs_Array.map(Array_data_util.randomRange(0, 39), (function (x) { + return /* tuple */[ + x, + x + ]; + }))); + +var u1 = Bs_Map.update(u0, 39, 120); + +b("File \"bs_map_test.ml\", line 83, characters 4-11", Bs_Array.forAll2(Bs_internalAVLtree.toArray0(u0.data), Bs_Array.map(Array_data_util.range(0, 39), (function (x) { + return /* tuple */[ + x, + x + ]; + })), (function (param, param$1) { + if (param[0] === param$1[0]) { + return +(param[1] === param$1[1]); + } else { + return /* false */0; + } + }))); + +b("File \"bs_map_test.ml\", line 88, characters 4-11", Bs_List.forAll2(Bs_internalAVLtree.toList0(u0.data), Bs_Array.toList(Bs_Array.map(Array_data_util.range(0, 39), (function (x) { + return /* tuple */[ + x, + x + ]; + }))), (function (param, param$1) { + if (param[0] === param$1[0]) { + return +(param[1] === param$1[1]); + } else { + return /* false */0; + } + }))); + +eq("File \"bs_map_test.ml\", line 93, characters 5-12", Bs_Map.findOpt(u0, 39), /* Some */[39]); + +eq("File \"bs_map_test.ml\", line 94, characters 5-12", Bs_Map.findOpt(u1, 39), /* Some */[120]); + +var u = f(Bs_Array.shuffle(Bs_Array.init(10000, (function (x) { + return /* tuple */[ + x, + x + ]; + })))); + +eq("File \"bs_map_test.ml\", line 100, characters 4-11", Bs_Array.init(10000, (function (x) { + return /* tuple */[ + x, + x + ]; + })), Bs_internalAVLtree.toArray0(u.data)); + +Mt.from_pair_suites("bs_map_test.ml", suites[0]); + var M = 0; var MI = 0; +var B = 0; + +var I = 0; + +var A = 0; + +var L = 0; + var vv = Bs_MapInt.empty; var vv2 = Bs_MapInt.empty; -var B = 0; - var ISet = 0; -exports.N = N; +exports.suites = suites; +exports.test_id = test_id; +exports.eq = eq; +exports.b = b; +exports.Icmp = Icmp; +exports.Icmp2 = Icmp2; exports.M = M; exports.MI = MI; -exports.m0 = m0; +exports.B = B; exports.I = I; +exports.A = A; +exports.L = L; +exports.m0 = m0; exports.I2 = I2; exports.m = m; exports.m2 = m2; exports.vv = vv; exports.vv2 = vv2; -exports.B = B; exports.ISet = ISet; +exports.f = f; +exports.$eq$tilde = $eq$tilde; /* data Not a pure module */ diff --git a/jscomp/test/bs_map_test.ml b/jscomp/test/bs_map_test.ml index a26f865e754..c02bc54a80e 100644 --- a/jscomp/test/bs_map_test.ml +++ b/jscomp/test/bs_map_test.ml @@ -1,21 +1,29 @@ +let suites : Mt.pair_suites ref = ref [] +let test_id = ref 0 +let eq loc x y = Mt.eq_suites ~suites ~test_id loc x y +let b loc v = Mt.bool_suites ~suites ~test_id loc v -module N = +module Icmp = (val Bs.Cmp.make (fun[@bs] (x : int) y -> compare x y ) ) -module M = Bs.Map -module MI = Bs.MapInt -let m0 : (_,string,_) M.t = M.empty (module N) - -module I = Bs.Cmp.Make( +module Icmp2 = Bs.Cmp.Make( struct type t = int let cmp = fun [@bs] (x : int) y -> compare x y end ) +module M = Bs.Map +module MI = Bs.MapInt +module B = Bs.Bag +module I = Array_data_util +module A = Bs_Array +module L = Bs.List +let m0 : (_,string,_) M.t = M.empty (module Icmp) + module I2 = Bs.Cmp.Make( struct @@ -25,52 +33,38 @@ module I2 = Bs.Cmp.Make( end ) -let m = Bs.Map.empty (module I) - +let m = M.empty (module Icmp2) let m2 : (int, string, _) M.t = M.empty (module I2) - let vv = MI.empty let vv2 = MI.empty -module B = Bs.Bag -(* let () = - Js.log (m = m2) *) + let () = let count = 1_000_00 in - - (* let {cmp; data} = m in *) let data = ref (B.data m) in let m2_dict, m_dict = B.(dict m2, dict m) in let module N = (val m2_dict) in - let module M = ( val m_dict) in - (* let vcmp = Bs.Cmp.getCmp M.cmp in *) + let module Mm = ( val m_dict) in for i = 0 to count do data := - Bs.Map.add0 !data - ~cmp: M.cmp - - (* M.cmp *) - (* (fun[@bs] x y -> compare x y) *) - - + M.update0 !data + ~cmp: Mm.cmp i i done ; let newm = B.bag ~data:!data ~dict:m_dict in Js.log newm - +module ISet = Bs.Set let () = - let m = Bs.Map.empty0 in + let m = M.empty0 in let m11 = - Bs.Map.add0 ~cmp:I.cmp m + M.update0 ~cmp:Icmp.cmp m 1 1 in - (* let m2 = - Bs.Map.add0 ~cmp:I2.cmp 1 3 m1 in *) - let _m20 = Bs.Map.empty (module I) in + let _m20 = M.empty (module Icmp) in Js.log m11 -module ISet = Bs.Set + let () = - let count = 100_000 in - let v = ISet.empty (module I) in + let count = 100_000 in + let v = ISet.empty (module Icmp2) in let m_dict = B.dict m in let module M = (val m_dict) in let cmp = M.cmp in @@ -78,5 +72,34 @@ let () = for i = 0 to count do data := Bs.Set.add0 ~cmp !data i done ; - Js.log !data - (* { v with data = !data} *) \ No newline at end of file + Js.log !data + +let f = M.ofArray (module Icmp) +let (=~) a b = M.eq a b + +let () = + let u0 = f (A.map (I.randomRange 0 39) (fun[@bs] x -> (x,x))) in + let u1 = M.update u0 39 120 in + b __LOC__ + (A.forAll2 (M.toArray u0) + (A.map (I.range 0 39) (fun [@bs] x -> (x,x))) + (fun[@bs] (x0,x1) (y0,y1) -> x0 = y0 && x1 = y1)); + + b __LOC__ + (L.forAll2 + (M.toList u0) + (A.toList (A.map (I.range 0 39) (fun [@bs] x -> (x,x)))) + (fun[@bs] (x0,x1) (y0,y1) -> x0 = y0 && x1 = y1)); + eq __LOC__ (M.findOpt u0 39) (Some 39); + eq __LOC__ (M.findOpt u1 39) (Some 120) + + +let () = + let u = f + (A.shuffle (A.init 10_000 (fun[@bs] x -> (x,x)))) in + eq __LOC__ + (A.init 10_000 (fun[@bs] x -> (x,x))) + (M.toArray u) + + +;; Mt.from_pair_suites __FILE__ !suites \ No newline at end of file diff --git a/jscomp/test/bs_poly_map_test.js b/jscomp/test/bs_poly_map_test.js new file mode 100644 index 00000000000..35f024ab212 --- /dev/null +++ b/jscomp/test/bs_poly_map_test.js @@ -0,0 +1,163 @@ +'use strict'; + +var Mt = require("./mt.js"); +var Bs_Map = require("../../lib/js/bs_Map.js"); +var Bs_Set = require("../../lib/js/bs_Set.js"); +var Bs_Array = require("../../lib/js/bs_Array.js"); +var Caml_primitive = require("../../lib/js/caml_primitive.js"); +var Array_data_util = require("./array_data_util.js"); +var Bs_internalAVLtree = require("../../lib/js/bs_internalAVLtree.js"); + +var suites = [/* [] */0]; + +var test_id = [0]; + +function eq(loc, x, y) { + return Mt.eq_suites(test_id, suites, loc, x, y); +} + +function b(loc, v) { + return Mt.bool_suites(test_id, suites, loc, v); +} + +var Icmp = /* module */[/* cmp */Caml_primitive.caml_int_compare]; + +function f(x) { + return Bs_Map.ofArray(Icmp, x); +} + +function ff(x) { + return Bs_Set.ofArray(Icmp, x); +} + +function mergeInter(s1, s2) { + var m = Bs_Map.merge(s1, s2, (function (_, v1, v2) { + if (v1 && v2) { + return /* Some */[/* () */0]; + } else { + return /* None */0; + } + })); + var x = Bs_internalAVLtree.keysToArray0(m.data); + return Bs_Set.ofArray(Icmp, x); +} + +function mergeUnion(s1, s2) { + var m = Bs_Map.merge(s1, s2, (function (_, v1, v2) { + if (v1) { + return /* Some */[/* () */0]; + } else if (v2) { + return /* Some */[/* () */0]; + } else { + return /* None */0; + } + })); + var x = Bs_internalAVLtree.keysToArray0(m.data); + return Bs_Set.ofArray(Icmp, x); +} + +function mergeDiff(s1, s2) { + var m = Bs_Map.merge(s1, s2, (function (_, v1, v2) { + if (v1 && !v2) { + return /* Some */[/* () */0]; + } else { + return /* None */0; + } + })); + var x = Bs_internalAVLtree.keysToArray0(m.data); + return Bs_Set.ofArray(Icmp, x); +} + +function randomRange(i, j) { + return Bs_Array.map(Array_data_util.randomRange(i, j), (function (x) { + return /* tuple */[ + x, + x + ]; + })); +} + +var x = randomRange(0, 100); + +var u0 = Bs_Map.ofArray(Icmp, x); + +var x$1 = randomRange(30, 120); + +var u1 = Bs_Map.ofArray(Icmp, x$1); + +var x$2 = Array_data_util.range(30, 100); + +b("File \"bs_poly_map_test.ml\", line 47, characters 4-11", Bs_Set.eq(mergeInter(u0, u1), Bs_Set.ofArray(Icmp, x$2))); + +var x$3 = Array_data_util.range(0, 120); + +b("File \"bs_poly_map_test.ml\", line 48, characters 4-11", Bs_Set.eq(mergeUnion(u0, u1), Bs_Set.ofArray(Icmp, x$3))); + +var x$4 = Array_data_util.range(0, 29); + +b("File \"bs_poly_map_test.ml\", line 49, characters 4-11", Bs_Set.eq(mergeDiff(u0, u1), Bs_Set.ofArray(Icmp, x$4))); + +var x$5 = Array_data_util.range(101, 120); + +b("File \"bs_poly_map_test.ml\", line 50, characters 4-11", Bs_Set.eq(mergeDiff(u1, u0), Bs_Set.ofArray(Icmp, x$5))); + +var x$6 = randomRange(0, 10); + +var a0 = Bs_Map.ofArray(Icmp, x$6); + +var a1 = Bs_Map.update(a0, 3, 33); + +var a2 = Bs_Map.remove(a1, 3); + +b("File \"bs_poly_map_test.ml\", line 57, characters 4-11", +(3 === Bs_Map.findNull(a0, 3))); + +b("File \"bs_poly_map_test.ml\", line 58, characters 4-11", +(33 === Bs_Map.findNull(a1, 3))); + +b("File \"bs_poly_map_test.ml\", line 59, characters 4-11", +(Bs_Map.findNull(a2, 3) === null)); + +var a3 = Bs_Map.updateWithOpt(a2, 3, (function (k) { + if (k) { + return /* Some */[k[0] + 1 | 0]; + } else { + return /* Some */[11]; + } + })); + +var a4 = Bs_Map.updateWithOpt(a2, 3, (function (k) { + if (k) { + return /* Some */[k[0] + 1 | 0]; + } else { + return /* None */0; + } + })); + +b("File \"bs_poly_map_test.ml\", line 70, characters 4-11", +(11 === Bs_Map.findNull(a3, 3))); + +b("File \"bs_poly_map_test.ml\", line 71, characters 4-11", +(Bs_Map.findNull(a4, 3) === null)); + +Mt.from_pair_suites("bs_poly_map_test.ml", suites[0]); + +var M = 0; + +var N = 0; + +var A = 0; + +var I = 0; + +exports.suites = suites; +exports.test_id = test_id; +exports.eq = eq; +exports.b = b; +exports.Icmp = Icmp; +exports.M = M; +exports.N = N; +exports.A = A; +exports.I = I; +exports.f = f; +exports.ff = ff; +exports.mergeInter = mergeInter; +exports.mergeUnion = mergeUnion; +exports.mergeDiff = mergeDiff; +exports.randomRange = randomRange; +/* x Not a pure module */ diff --git a/jscomp/test/bs_poly_map_test.ml b/jscomp/test/bs_poly_map_test.ml new file mode 100644 index 00000000000..22b12d605de --- /dev/null +++ b/jscomp/test/bs_poly_map_test.ml @@ -0,0 +1,72 @@ +let suites : Mt.pair_suites ref = ref [] +let test_id = ref 0 +let eq loc x y = Mt.eq_suites ~suites ~test_id loc x y +let b loc v = Mt.bool_suites ~suites ~test_id loc v + +module Icmp = + (val Bs.Cmp.make + (fun[@bs] (x : int) y -> + compare x y + ) + ) +module M = Bs.Map +module N = Bs.Set + +module A = Bs_Array +module I = Array_data_util +let f x = M.ofArray (module Icmp) x +let ff x = N.ofArray (module Icmp) x + +let mergeInter s1 s2 = + ff @@ M.keysToArray (M.merge s1 s2 (fun[@bs] k v1 v2 -> + match v1,v2 with + | Some _, Some _ -> Some () + | _, _ -> None + )) + +let mergeUnion s1 s2 = + ff @@ M.keysToArray @@ M.merge s1 s2 (fun[@bs] k v1 v2 -> + match v1,v2 with + | None, None -> None + | _, _ -> Some () + ) +let mergeDiff s1 s2 = + ff @@ M.keysToArray @@ M.merge s1 s2 (fun[@bs] k v1 v2 -> + match v1,v2 with + | Some _, None -> Some () + | Some _, Some _ + | None, _ -> None + ) + +let randomRange i j = + A.map (I.randomRange i j) (fun[@bs] x -> (x,x)) + +let () = + let u0 = f (randomRange 0 100) in + let u1 = f (randomRange 30 120) in + b __LOC__ (N.eq (mergeInter u0 u1) (ff (I.range 30 100))); + b __LOC__ (N.eq (mergeUnion u0 u1) (ff (I.range 0 120))); + b __LOC__ (N.eq (mergeDiff u0 u1) (ff (I.range 0 29))); + b __LOC__ (N.eq (mergeDiff u1 u0) (ff (I.range 101 120))) + + +let () = + let a0 = f (randomRange 0 10) in + let a1 = M.update a0 3 33 in + let a2 = M.remove a1 3 in + b __LOC__ (Js.eqNull 3 (M.findNull a0 3)); + b __LOC__ (Js.eqNull 33 (M.findNull a1 3)); + b __LOC__ (Js.Null.test (M.findNull a2 3)); + let a3 = M.updateWithOpt a2 3 (fun[@bs] k -> + match k with + | Some k -> Some (k + 1) + | None -> Some 11 + ) in + let a4 = M.updateWithOpt a2 3 (fun[@bs] k -> + match k with + | Some k-> Some (k + 1) + | None -> None + ) in + b __LOC__ (Js.eqNull 11 (M.findNull a3 3)); + b __LOC__ (Js.Null.test (M.findNull a4 3)) +;; Mt.from_pair_suites __FILE__ !suites \ No newline at end of file diff --git a/jscomp/test/bs_set_int_test.js b/jscomp/test/bs_set_int_test.js index f850fb49d1d..8d03d7df293 100644 --- a/jscomp/test/bs_set_int_test.js +++ b/jscomp/test/bs_set_int_test.js @@ -207,23 +207,21 @@ var v$10 = Bs_SetInt.remove(v$9, 1); b("File \"bs_set_int_test.ml\", line 95, characters 4-11", Bs_SetInt.isEmpty(v$10)); -var v$11 = Bs_Array.init(1000000, (function (i) { - return i; - })); - -Bs_Array.shuffleInPlace(v$11); +var v$11 = Bs_Array.shuffle(Bs_Array.init(1000000, (function (i) { + return i; + }))); var u$1 = Bs_SetInt.ofArray(v$11); -b("File \"bs_set_int_test.ml\", line 103, characters 4-11", Bs_SetInt.checkInvariant(u$1)); +b("File \"bs_set_int_test.ml\", line 102, characters 4-11", Bs_SetInt.checkInvariant(u$1)); var firstHalf = Bs_Array.sub(v$11, 0, 2000); var xx = Bs_Array.foldLeft(firstHalf, u$1, Bs_SetInt.remove); -b("File \"bs_set_int_test.ml\", line 107, characters 4-11", Bs_SetInt.checkInvariant(u$1)); +b("File \"bs_set_int_test.ml\", line 106, characters 4-11", Bs_SetInt.checkInvariant(u$1)); -b("File \"bs_set_int_test.ml\", line 108, characters 4-11", Bs_SetInt.eq(Bs_SetInt.union(Bs_SetInt.ofArray(firstHalf), xx), u$1)); +b("File \"bs_set_int_test.ml\", line 107, characters 4-11", Bs_SetInt.eq(Bs_SetInt.union(Bs_SetInt.ofArray(firstHalf), xx), u$1)); var aa = Bs_SetInt.ofArray(Array_data_util.randomRange(0, 100)); @@ -233,17 +231,17 @@ var cc = Bs_SetInt.ofArray(Array_data_util.randomRange(120, 200)); var dd = Bs_SetInt.union(aa, cc); -b("File \"bs_set_int_test.ml\", line 115, characters 4-11", Bs_SetInt.subset(aa, bb)); +b("File \"bs_set_int_test.ml\", line 114, characters 4-11", Bs_SetInt.subset(aa, bb)); -b("File \"bs_set_int_test.ml\", line 116, characters 4-11", Bs_SetInt.subset(dd, bb)); +b("File \"bs_set_int_test.ml\", line 115, characters 4-11", Bs_SetInt.subset(dd, bb)); -b("File \"bs_set_int_test.ml\", line 117, characters 4-11", Bs_SetInt.subset(Bs_SetInt.add(dd, 200), bb)); +b("File \"bs_set_int_test.ml\", line 116, characters 4-11", Bs_SetInt.subset(Bs_SetInt.add(dd, 200), bb)); -b("File \"bs_set_int_test.ml\", line 118, characters 4-11", +(Bs_SetInt.add(dd, 200) === dd)); +b("File \"bs_set_int_test.ml\", line 117, characters 4-11", +(Bs_SetInt.add(dd, 200) === dd)); -b("File \"bs_set_int_test.ml\", line 119, characters 4-11", +(Bs_SetInt.add(dd, 0) === dd)); +b("File \"bs_set_int_test.ml\", line 118, characters 4-11", +(Bs_SetInt.add(dd, 0) === dd)); -b("File \"bs_set_int_test.ml\", line 120, characters 4-11", 1 - Bs_SetInt.subset(Bs_SetInt.add(dd, 201), bb)); +b("File \"bs_set_int_test.ml\", line 119, characters 4-11", 1 - Bs_SetInt.subset(Bs_SetInt.add(dd, 201), bb)); var aa$1 = Bs_SetInt.ofArray(Array_data_util.randomRange(0, 100)); @@ -255,13 +253,13 @@ var dd$1 = Bs_SetInt.remove(bb$1, 99); var ee = Bs_SetInt.add(dd$1, 101); -b("File \"bs_set_int_test.ml\", line 129, characters 4-11", Bs_SetInt.eq(aa$1, bb$1)); +b("File \"bs_set_int_test.ml\", line 128, characters 4-11", Bs_SetInt.eq(aa$1, bb$1)); -b("File \"bs_set_int_test.ml\", line 130, characters 4-11", 1 - Bs_SetInt.eq(aa$1, cc$1)); +b("File \"bs_set_int_test.ml\", line 129, characters 4-11", 1 - Bs_SetInt.eq(aa$1, cc$1)); -b("File \"bs_set_int_test.ml\", line 131, characters 4-11", 1 - Bs_SetInt.eq(dd$1, cc$1)); +b("File \"bs_set_int_test.ml\", line 130, characters 4-11", 1 - Bs_SetInt.eq(dd$1, cc$1)); -b("File \"bs_set_int_test.ml\", line 132, characters 4-11", 1 - Bs_SetInt.eq(bb$1, ee)); +b("File \"bs_set_int_test.ml\", line 131, characters 4-11", 1 - Bs_SetInt.eq(bb$1, ee)); Mt.from_pair_suites("bs_set_int_test.ml", suites[0]); @@ -269,6 +267,8 @@ var N = 0; var I = 0; +var A = 0; + var ofA = Bs_SetInt.ofArray; exports.suites = suites; @@ -277,6 +277,7 @@ exports.eq = eq; exports.b = b; exports.N = N; exports.I = I; +exports.A = A; exports.$eq$tilde = $eq$tilde; exports.$eq$star = $eq$star; exports.ofA = ofA; diff --git a/jscomp/test/bs_set_int_test.ml b/jscomp/test/bs_set_int_test.ml index 0344ff4e6fd..105cf5233a5 100644 --- a/jscomp/test/bs_set_int_test.ml +++ b/jscomp/test/bs_set_int_test.ml @@ -6,7 +6,7 @@ let b loc v = Mt.bool_suites ~suites ~test_id loc v module N = Bs.SetInt module I = Array_data_util - +module A = Bs_Array let (=~) s i = N.(eq (ofArray i) s) let (=*) a b = @@ -97,8 +97,7 @@ let () = let () = let count = 1_000_000 in - let v = Bs.Array.init count (fun [@bs] i -> i) in - Bs.Array.shuffleInPlace v ; + let v = (A.shuffle (A.init count (fun [@bs] i -> i))) in let u = N.ofArray v in b __LOC__ (N.checkInvariant u ); let firstHalf = Bs.Array.sub v 0 2_000 in diff --git a/jscomp/test/bs_sort_test.js b/jscomp/test/bs_sort_test.js index 90a6d345eb1..b4fae6d3e59 100644 --- a/jscomp/test/bs_sort_test.js +++ b/jscomp/test/bs_sort_test.js @@ -342,6 +342,61 @@ b("File \"bs_sort_test.ml\", line 127, characters 4-11", Bs_Range.forAll(0, 1999 return +((Bs_Sort.binSearch(cc, (i << 1) + 1 | 0, cmp) ^ -1) === (i + 1 | 0)); }))); +function lt(x, y) { + return +(x < y); +} + +eq("File \"bs_sort_test.ml\", line 134, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[], lt), 0); + +eq("File \"bs_sort_test.ml\", line 135, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[1], lt), 1); + +eq("File \"bs_sort_test.ml\", line 136, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[ + 1, + 1 + ], lt), 1); + +eq("File \"bs_sort_test.ml\", line 137, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[ + 1, + 1, + 2 + ], lt), 1); + +eq("File \"bs_sort_test.ml\", line 138, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[ + 1, + 2 + ], lt), 2); + +eq("File \"bs_sort_test.ml\", line 139, characters 5-12", Bs_Sort.strictlySortedLength(/* array */[ + 1, + 2, + 3, + 4, + 3 + ], lt), 4); + +eq("File \"bs_sort_test.ml\", line 140, characters 5-12", Bs_Sort.strictlySortedLength(/* array */[ + 4, + 4, + 3, + 2, + 1 + ], lt), 1); + +eq("File \"bs_sort_test.ml\", line 141, characters 5-12", Bs_Sort.strictlySortedLength(/* int array */[ + 4, + 3, + 2, + 1 + ], lt), -4); + +eq("File \"bs_sort_test.ml\", line 142, characters 5-12", Bs_Sort.strictlySortedLength(/* array */[ + 4, + 3, + 2, + 1, + 0 + ], lt), -5); + Mt.from_pair_suites("bs_sort_test.ml", suites[0]); var I = 0; @@ -367,4 +422,5 @@ exports.unions = unions; exports.inters = inters; exports.diffs = diffs; exports.SI = SI; +exports.lt = lt; /* Not a pure module */ diff --git a/jscomp/test/bs_sort_test.ml b/jscomp/test/bs_sort_test.ml index b7e719f0ed2..34b8ffe6b1f 100644 --- a/jscomp/test/bs_sort_test.ml +++ b/jscomp/test/bs_sort_test.ml @@ -129,4 +129,16 @@ let () = (* 1, 3, 5, ... , 3999 *) ) +let lt = fun [@bs] (x : int) y -> x < y +let () = + eq __LOC__ (S.strictlySortedLength [||] lt) 0 ; + eq __LOC__ (S.strictlySortedLength [|1|] lt) 1; + eq __LOC__ (S.strictlySortedLength [|1;1|] lt) 1; + eq __LOC__ (S.strictlySortedLength [|1;1;2|] lt) 1; + eq __LOC__ (S.strictlySortedLength [|1;2|] lt) 2; + eq __LOC__ (S.strictlySortedLength [|1;2;3;4;3|] lt) 4; + eq __LOC__ (S.strictlySortedLength [|4;4;3;2;1|] lt) 1; + eq __LOC__ (S.strictlySortedLength [|4;3;2;1|] lt) (-4); + eq __LOC__ (S.strictlySortedLength [|4;3;2;1;0|] lt) (-5); + ;; Mt.from_pair_suites __FILE__ !suites \ No newline at end of file diff --git a/jscomp/test/bs_stack_test.ml b/jscomp/test/bs_stack_test.ml index 3567d061bae..cef16c585cc 100644 --- a/jscomp/test/bs_stack_test.ml +++ b/jscomp/test/bs_stack_test.ml @@ -18,17 +18,17 @@ let inOrder (v : t) = let s : node S.t = S.create () in let q : int Q.t = Q.create () in while !current != Js.null do - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in S.push s v; current := left v; done ; while not (S.isEmpty s ) do current := S.popNull s ; - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in Q.push q (value v); current := right v ; while !current != Js.null do - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in S.push s v; current := left v; done ; @@ -40,7 +40,7 @@ let inOrder3 (v : t) = let s : node S.t = S.create () in let q : int Q.t = Q.create () in while !current != Js.null do - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in S.push s v; current := left v; done ; @@ -48,7 +48,7 @@ let inOrder3 (v : t) = Q.push q (value popped); let current = ref (right popped) in while !current != Js.null do - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in S.push s v; current := left v done @@ -63,14 +63,14 @@ let inOrder2 (v : t) = while !todo do if !cursor != Js.null then ( - let v = (Js.Null.castUnsafe !cursor) in + let v = (Js.Null.getUnsafe !cursor) in S.push s v; cursor := left v) else begin if not (S.isEmpty s) then (cursor := S.popNull s ; - let current = Js.Null.castUnsafe !cursor in + let current = Js.Null.getUnsafe !cursor in Q.push q (value current); cursor := right current) else @@ -96,7 +96,7 @@ let test1 = let pushAllLeft st1 s1 = let current = ref st1 in while !current != Js.null do - let v = Js.Null.castUnsafe !current in + let v = Js.Null.getUnsafe !current in S.push s1 v; current := left v; done diff --git a/lib/js/bs_Array.js b/lib/js/bs_Array.js index ed872ded8d8..a44fea18677 100644 --- a/lib/js/bs_Array.js +++ b/lib/js/bs_Array.js @@ -21,7 +21,7 @@ function swapUnsafe(xs, i, j) { return /* () */0; } -function shuffleInPlace(xs) { +function shuffleOnly(xs) { var len = xs.length; for(var i = 0 ,i_finish = len - 1 | 0; i <= i_finish; ++i){ swapUnsafe(xs, i, Js_math.random_int(i, len)); @@ -29,9 +29,14 @@ function shuffleInPlace(xs) { return /* () */0; } +function shuffle(xs) { + shuffleOnly(xs); + return xs; +} + function makeMatrix(sx, sy, init) { if (!(sx >= 0 && sy >= 0)) { - throw new Error("File \"bs_Array.ml\", line 55, characters 4-10"); + throw new Error("File \"bs_Array.ml\", line 57, characters 4-10"); } var res = new Array(sx); for(var x = 0 ,x_finish = sx - 1 | 0; x <= x_finish; ++x){ @@ -262,7 +267,8 @@ function forAll2(a, b, p) { var concat = Caml_array.caml_array_concat; exports.init = init; -exports.shuffleInPlace = shuffleInPlace; +exports.shuffleOnly = shuffleOnly; +exports.shuffle = shuffle; exports.zip = zip; exports.makeMatrix = makeMatrix; exports.append = append; diff --git a/lib/js/bs_Map.js b/lib/js/bs_Map.js index a7de34cd080..21d442dcb49 100644 --- a/lib/js/bs_Map.js +++ b/lib/js/bs_Map.js @@ -2,126 +2,79 @@ var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); -function add0(t, x, data, cmp) { +function update0(t, newK, newD, cmp) { if (t !== null) { - var l = t.left; var k = t.key; - var v = t.value; - var r = t.right; - var c = cmp(x, k); + var c = cmp(newK, k); if (c) { + var l = t.left; + var r = t.right; + var v = t.value; if (c < 0) { - return Bs_internalAVLtree.bal(add0(l, x, data, cmp), k, v, r); + return Bs_internalAVLtree.bal(update0(l, newK, newD, cmp), k, v, r); } else { - return Bs_internalAVLtree.bal(l, k, v, add0(r, x, data, cmp)); + return Bs_internalAVLtree.bal(l, k, v, update0(r, newK, newD, cmp)); } } else { - return { - left: l, - key: x, - value: data, - right: r, - h: t.h - }; + return Bs_internalAVLtree.updateKV(t, newK, newD); } } else { - return { - left: null, - key: x, - value: data, - right: null, - h: 1 - }; + return Bs_internalAVLtree.singleton0(newK, newD); } } -function findOpt0(_n, x, cmp) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - var c = cmp(x, v); - if (c) { - _n = c < 0 ? n.left : n.right; - continue ; - - } else { - return /* Some */[n.value]; - } - } else { - return /* None */0; - } - }; -} - -function findAssert0(_n, x, cmp) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - var c = cmp(x, v); - if (c) { - _n = c < 0 ? n.left : n.right; - continue ; - +function updateWithOpt0(t, newK, f, cmp) { + if (t !== null) { + var k = t.key; + var c = cmp(newK, k); + if (c) { + var l = t.left; + var r = t.right; + var v = t.value; + if (c < 0) { + return Bs_internalAVLtree.bal(updateWithOpt0(l, newK, f, cmp), k, v, r); } else { - return n.value; + return Bs_internalAVLtree.bal(l, k, v, updateWithOpt0(r, newK, f, cmp)); } } else { - throw new Error("Not_found"); - } - }; -} - -function findWithDefault0(_n, x, def, cmp) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - var c = cmp(x, v); - if (c) { - _n = c < 0 ? n.left : n.right; - continue ; - + var match = f(/* Some */[k]); + if (match) { + return Bs_internalAVLtree.updateKV(t, newK, match[0]); } else { - return n.value; + return t; } - } else { - return def; } - }; -} - -function mem0(x, _n, cmp) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - var c = cmp(x, v); - if (c) { - _n = c < 0 ? n.left : n.right; - continue ; - - } else { - return /* true */1; - } + } else { + var match$1 = f(/* None */0); + if (match$1) { + return Bs_internalAVLtree.singleton0(newK, match$1[0]); } else { - return /* false */0; + return t; } - }; + } } -function remove0(n, x, cmp) { - if (n !== null) { - var l = n.left; - var v = n.key; - var r = n.right; +function remove0(t, x, cmp) { + if (t !== null) { + var l = t.left; + var v = t.key; + var r = t.right; var c = cmp(x, v); if (c) { if (c < 0) { - return Bs_internalAVLtree.bal(remove0(l, x, cmp), v, n.value, r); + var ll = remove0(l, x, cmp); + if (ll === l) { + return t; + } else { + return Bs_internalAVLtree.bal(ll, v, t.value, r); + } } else { - return Bs_internalAVLtree.bal(l, v, n.value, remove0(r, x, cmp)); + var rr = remove0(r, x, cmp); + if (rr === r) { + return t; + } else { + return Bs_internalAVLtree.bal(l, v, t.value, rr); + } } } else if (l !== null) { if (r !== null) { @@ -136,11 +89,11 @@ function remove0(n, x, cmp) { return r; } } else { - return n; + return t; } } -function splitAux(cmp, x, n) { +function splitAuxPivot(cmp, n, x, pres) { var l = n.left; var v = n.key; var d = n.value; @@ -149,174 +102,97 @@ function splitAux(cmp, x, n) { if (c) { if (c < 0) { if (l !== null) { - var match = splitAux(cmp, x, l); + var match = splitAuxPivot(cmp, l, x, pres); return /* tuple */[ match[0], - match[1], - Bs_internalAVLtree.join(match[2], v, d, r) + Bs_internalAVLtree.join(match[1], v, d, r) ]; } else { return /* tuple */[ null, - /* None */0, n ]; } } else if (r !== null) { - var match$1 = splitAux(cmp, x, r); + var match$1 = splitAuxPivot(cmp, r, x, pres); return /* tuple */[ Bs_internalAVLtree.join(l, v, d, match$1[0]), - match$1[1], - match$1[2] + match$1[1] ]; } else { return /* tuple */[ n, - /* None */0, null ]; } } else { + pres[0] = /* Some */[d]; return /* tuple */[ l, - /* Some */[d], r ]; } } -function split0(cmp, x, n) { +function split0(cmp, n, x) { if (n !== null) { - return splitAux(cmp, x, n); + var pres = [/* None */0]; + var v = splitAuxPivot(cmp, n, x, pres); + return /* tuple */[ + v, + pres[0] + ]; } else { return /* tuple */[ - null, - /* None */0, - null + /* tuple */[ + null, + null + ], + /* None */0 ]; } } function merge0(s1, s2, f, cmp) { - var exit = 0; if (s1 !== null) { - if (s1.h >= ( - s2 !== null ? s2.h : 0 - )) { - var l1 = s1.left; - var v1 = s1.key; - var d1 = s1.value; - var r1 = s1.right; - var match = split0(cmp, v1, s2); - return Bs_internalAVLtree.concatOrJoin(merge0(l1, match[0], f, cmp), v1, f(v1, /* Some */[d1], match[1]), merge0(r1, match[2], f, cmp)); + if (s2 !== null) { + if (s1.h >= s2.h) { + var l1 = s1.left; + var v1 = s1.key; + var d1 = s1.value; + var r1 = s1.right; + var d2 = [/* None */0]; + var match = splitAuxPivot(cmp, s2, v1, d2); + var d2$1 = d2[0]; + var newLeft = merge0(l1, match[0], f, cmp); + var newD = f(v1, /* Some */[d1], d2$1); + var newRight = merge0(r1, match[1], f, cmp); + return Bs_internalAVLtree.concatOrJoin(newLeft, v1, newD, newRight); + } else { + var l2 = s2.left; + var v2 = s2.key; + var d2$2 = s2.value; + var r2 = s2.right; + var d1$1 = [/* None */0]; + var match$1 = splitAuxPivot(cmp, s1, v2, d1$1); + var d1$2 = d1$1[0]; + var newLeft$1 = merge0(match$1[0], l2, f, cmp); + var newD$1 = f(v2, d1$2, /* Some */[d2$2]); + var newRight$1 = merge0(match$1[1], r2, f, cmp); + return Bs_internalAVLtree.concatOrJoin(newLeft$1, v2, newD$1, newRight$1); + } } else { - exit = 1; + return Bs_internalAVLtree.filterMap0(s1, (function (k, v) { + return f(k, /* Some */[v], /* None */0); + })); } } else if (s2 !== null) { - exit = 1; + return Bs_internalAVLtree.filterMap0(s2, (function (k, v) { + return f(k, /* None */0, /* Some */[v]); + })); } else { return null; } - if (exit === 1) { - if (s2 !== null) { - var l2 = s2.left; - var v2 = s2.key; - var d2 = s2.value; - var r2 = s2.right; - var match$1 = split0(cmp, v2, s1); - return Bs_internalAVLtree.concatOrJoin(merge0(match$1[0], l2, f, cmp), v2, f(v2, match$1[1], /* Some */[d2]), merge0(match$1[2], r2, f, cmp)); - } else { - return /* assert false */0; - } - } - -} - -function cmp0(s1, s2, kcmp, vcmp) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var kcmp$1 = kcmp; - var vcmp$1 = vcmp; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - var c = kcmp$1(h1.key, h2.key); - if (c) { - return c; - } else { - var cx = vcmp$1(h1.value, h2.value); - if (cx) { - return cx; - } else { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } - } - } else { - return 0; - } - } else { - return 0; - } - }; - } else if (len1 < len2) { - return -1; - } else { - return 1; - } -} - -function eq0(s1, s2, kcmp, vcmp) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var kcmp$1 = kcmp; - var vcmp$1 = vcmp; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - if (kcmp$1(h1.key, h2.key) === 0 && vcmp$1(h1.value, h2.value)) { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } else { - return /* false */0; - } - } else { - return /* true */1; - } - } else { - return /* true */1; - } - }; - } else { - return /* false */0; - } -} - -function ofArray0(cmp, xs) { - var result = null; - for(var i = 0 ,i_finish = xs.length - 1 | 0; i <= i_finish; ++i){ - var match = xs[i]; - result = add0(result, match[0], match[1], cmp); - } - return result; } function empty(dict) { @@ -358,14 +234,14 @@ function filter(f, map) { var map$1 = map.data; return { dict: dict, - data: Bs_internalAVLtree.filter0(f, map$1) + data: Bs_internalAVLtree.filterShared0(f, map$1) }; } function partition(p, map) { var dict = map.dict; var map$1 = map.data; - var match = Bs_internalAVLtree.partition0(p, map$1); + var match = Bs_internalAVLtree.partitionShared0(p, map$1); return /* tuple */[ { dict: dict, @@ -386,12 +262,32 @@ function toList(map) { return Bs_internalAVLtree.toList0(map.data); } -function minBinding(map) { - return Bs_internalAVLtree.minKVOpt0(map.data); +function toArray(m) { + return Bs_internalAVLtree.toArray0(m.data); +} + +function keysToArray(m) { + return Bs_internalAVLtree.keysToArray0(m.data); +} + +function valuesToArray(m) { + return Bs_internalAVLtree.valuesToArray0(m.data); } -function maxBinding(map) { - return Bs_internalAVLtree.maxKVOpt0(map.data); +function minKVOpt(m) { + return Bs_internalAVLtree.minKVOpt0(m.data); +} + +function minKVNull(m) { + return Bs_internalAVLtree.minKVNull0(m.data); +} + +function maxKVOpt(m) { + return Bs_internalAVLtree.maxKVOpt0(m.data); +} + +function maxKVNull(m) { + return Bs_internalAVLtree.maxKVNull0(m.data); } function map(m, f) { @@ -412,44 +308,59 @@ function mapi(map, f) { }; } -function add(map, key, data) { +function update(map, key, data) { var dict = map.dict; var map$1 = map.data; return { dict: dict, - data: add0(map$1, key, data, dict[/* cmp */0]) + data: update0(map$1, key, data, dict[/* cmp */0]) + }; +} + +function updateWithOpt(map, key, f) { + var dict = map.dict; + var map$1 = map.data; + return { + dict: dict, + data: updateWithOpt0(map$1, key, f, dict[/* cmp */0]) }; } function ofArray(dict, data) { return { dict: dict, - data: ofArray0(dict[/* cmp */0], data) + data: Bs_internalAVLtree.ofArray0(dict[/* cmp */0], data) }; } function findOpt(map, x) { var dict = map.dict; var map$1 = map.data; - return findOpt0(map$1, x, dict[/* cmp */0]); + return Bs_internalAVLtree.findOpt0(map$1, x, dict[/* cmp */0]); } -function findAssert(map, x) { +function findNull(map, x) { var dict = map.dict; var map$1 = map.data; - return findAssert0(map$1, x, dict[/* cmp */0]); + return Bs_internalAVLtree.findNull0(map$1, x, dict[/* cmp */0]); } function findWithDefault(map, x, def) { var dict = map.dict; var map$1 = map.data; - return findWithDefault0(map$1, x, def, dict[/* cmp */0]); + return Bs_internalAVLtree.findWithDefault0(map$1, x, def, dict[/* cmp */0]); +} + +function findExn(map, x) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.findExn0(map$1, x, dict[/* cmp */0]); } function mem(map, x) { var dict = map.dict; var map$1 = map.data; - return mem0(x, map$1, dict[/* cmp */0]); + return Bs_internalAVLtree.mem0(map$1, x, dict[/* cmp */0]); } function remove(map, x) { @@ -461,20 +372,23 @@ function remove(map, x) { }; } -function split(x, map) { +function split(map, x) { var dict = map.dict; var map$1 = map.data; - var match = split0(dict[/* cmp */0], x, map$1); + var match = split0(dict[/* cmp */0], map$1, x); + var match$1 = match[0]; return /* tuple */[ - { - dict: dict, - data: match[0] - }, - match[1], - { - dict: dict, - data: match[2] - } + /* tuple */[ + { + dict: dict, + data: match$1[0] + }, + { + dict: dict, + data: match$1[1] + } + ], + match[1] ]; } @@ -492,22 +406,30 @@ function cmp(m1, m2, cmp$1) { var dict = m1.dict; var m1_data = m1.data; var m2_data = m2.data; - return cmp0(m1_data, m2_data, dict[/* cmp */0], cmp$1); + return Bs_internalAVLtree.cmp0(m1_data, m2_data, dict[/* cmp */0], cmp$1); } function eq(m1, m2, cmp) { var dict = m1.dict; var m1_data = m1.data; var m2_data = m2.data; - return eq0(m1_data, m2_data, dict[/* cmp */0], cmp); + return Bs_internalAVLtree.eq0(m1_data, m2_data, dict[/* cmp */0], cmp); } var empty0 = Bs_internalAVLtree.empty0; +var ofArray0 = Bs_internalAVLtree.ofArray0; + var isEmpty0 = Bs_internalAVLtree.isEmpty0; +var mem0 = Bs_internalAVLtree.mem0; + var singleton0 = Bs_internalAVLtree.singleton0; +var cmp0 = Bs_internalAVLtree.cmp0; + +var eq0 = Bs_internalAVLtree.eq0; + var iter0 = Bs_internalAVLtree.iter0; var fold0 = Bs_internalAVLtree.fold0; @@ -516,17 +438,25 @@ var forAll0 = Bs_internalAVLtree.forAll0; var exists0 = Bs_internalAVLtree.exists0; -var filter0 = Bs_internalAVLtree.filter0; +var filter0 = Bs_internalAVLtree.filterShared0; -var partition0 = Bs_internalAVLtree.partition0; +var partition0 = Bs_internalAVLtree.partitionShared0; var length0 = Bs_internalAVLtree.length0; var toList0 = Bs_internalAVLtree.toList0; -var minBinding0 = Bs_internalAVLtree.minKVOpt0; +var minKVOpt0 = Bs_internalAVLtree.minKVOpt0; + +var maxKVOpt0 = Bs_internalAVLtree.maxKVOpt0; + +var findOpt0 = Bs_internalAVLtree.findOpt0; + +var findNull0 = Bs_internalAVLtree.findNull0; + +var findWithDefault0 = Bs_internalAVLtree.findWithDefault0; -var maxBinding0 = Bs_internalAVLtree.maxKVOpt0; +var findExn0 = Bs_internalAVLtree.findExn0; var map0 = Bs_internalAVLtree.map0; @@ -536,7 +466,8 @@ exports.empty = empty; exports.ofArray = ofArray; exports.isEmpty = isEmpty; exports.mem = mem; -exports.add = add; +exports.update = update; +exports.updateWithOpt = updateWithOpt; exports.singleton = singleton; exports.remove = remove; exports.merge = merge; @@ -550,19 +481,25 @@ exports.filter = filter; exports.partition = partition; exports.length = length; exports.toList = toList; -exports.minBinding = minBinding; -exports.maxBinding = maxBinding; +exports.toArray = toArray; +exports.keysToArray = keysToArray; +exports.valuesToArray = valuesToArray; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; exports.split = split; exports.findOpt = findOpt; -exports.findAssert = findAssert; +exports.findNull = findNull; exports.findWithDefault = findWithDefault; +exports.findExn = findExn; exports.map = map; exports.mapi = mapi; exports.empty0 = empty0; exports.ofArray0 = ofArray0; exports.isEmpty0 = isEmpty0; exports.mem0 = mem0; -exports.add0 = add0; +exports.update0 = update0; exports.singleton0 = singleton0; exports.remove0 = remove0; exports.merge0 = merge0; @@ -576,12 +513,13 @@ exports.filter0 = filter0; exports.partition0 = partition0; exports.length0 = length0; exports.toList0 = toList0; -exports.minBinding0 = minBinding0; -exports.maxBinding0 = maxBinding0; +exports.minKVOpt0 = minKVOpt0; +exports.maxKVOpt0 = maxKVOpt0; exports.split0 = split0; exports.findOpt0 = findOpt0; -exports.findAssert0 = findAssert0; +exports.findNull0 = findNull0; exports.findWithDefault0 = findWithDefault0; +exports.findExn0 = findExn0; exports.map0 = map0; exports.mapi0 = mapi0; /* No side effect */ diff --git a/lib/js/bs_MapInt.js b/lib/js/bs_MapInt.js index 6fba078cb73..cdf1096083e 100644 --- a/lib/js/bs_MapInt.js +++ b/lib/js/bs_MapInt.js @@ -1,108 +1,52 @@ 'use strict'; -var Caml_primitive = require("./caml_primitive.js"); +var Bs_internalMapInt = require("./bs_internalMapInt.js"); var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); -function add(t, x, data) { +function update(t, newK, newD) { if (t !== null) { - var l = t.left; var k = t.key; - var v = t.value; - var r = t.right; - if (x === k) { - return { - left: l, - key: x, - value: data, - right: r, - h: t.h - }; - } else if (x < k) { - return Bs_internalAVLtree.bal(add(l, x, data), k, v, r); + if (newK === k) { + return Bs_internalAVLtree.updateKV(t, newK, newD); } else { - return Bs_internalAVLtree.bal(l, k, v, add(r, x, data)); - } - } else { - return { - left: null, - key: x, - value: data, - right: null, - h: 1 - }; - } -} - -function findOpt(x, _n) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return /* Some */[n.value]; + var v = t.value; + if (newK < k) { + return Bs_internalAVLtree.bal(update(t.left, newK, newD), k, v, t.right); } else { - _n = x < v ? n.left : n.right; - continue ; - + return Bs_internalAVLtree.bal(t.left, k, v, update(t.right, newK, newD)); } - } else { - return /* None */0; } - }; + } else { + return Bs_internalAVLtree.singleton0(newK, newD); + } } -function findAssert(x, _n) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return n.value; +function updateWithOpt(t, x, f) { + if (t !== null) { + var k = t.key; + if (x === k) { + var match = f(/* Some */[k]); + if (match) { + return Bs_internalAVLtree.updateKV(t, x, match[0]); } else { - _n = x < v ? n.left : n.right; - continue ; - + return t; } } else { - throw new Error("Not_found"); - } - }; -} - -function findWithDefault(_n, x, def) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return n.value; + var v = t.value; + if (x < k) { + return Bs_internalAVLtree.bal(updateWithOpt(t.left, x, f), k, v, t.right); } else { - _n = x < v ? n.left : n.right; - continue ; - + return Bs_internalAVLtree.bal(t.left, k, v, updateWithOpt(t.right, x, f)); } - } else { - return def; } - }; -} - -function mem(_n, x) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return /* true */1; - } else { - _n = x < v ? n.left : n.right; - continue ; - - } + } else { + var match$1 = f(/* None */0); + if (match$1) { + return Bs_internalAVLtree.singleton0(x, match$1[0]); } else { - return /* false */0; + return t; } - }; + } } function remove(n, x) { @@ -133,185 +77,21 @@ function remove(n, x) { } } -function splitAux(x, n) { - var l = n.left; - var v = n.key; - var d = n.value; - var r = n.right; - if (x === v) { - return /* tuple */[ - l, - /* Some */[d], - r - ]; - } else if (x < v) { - if (l !== null) { - var match = splitAux(x, l); - return /* tuple */[ - match[0], - match[1], - Bs_internalAVLtree.join(match[2], v, d, r) - ]; - } else { - return /* tuple */[ - null, - /* None */0, - n - ]; - } - } else if (r !== null) { - var match$1 = splitAux(x, r); - return /* tuple */[ - Bs_internalAVLtree.join(l, v, d, match$1[0]), - match$1[1], - match$1[2] - ]; - } else { - return /* tuple */[ - n, - /* None */0, - null - ]; - } -} +var empty = Bs_internalAVLtree.empty0; -function split(x, n) { - if (n !== null) { - return splitAux(x, n); - } else { - return /* tuple */[ - null, - /* None */0, - null - ]; - } -} +var ofArray = Bs_internalMapInt.ofArray; -function merge(s1, s2, f) { - var exit = 0; - if (s1 !== null) { - if (s1.h >= ( - s2 !== null ? s2.h : 0 - )) { - var l1 = s1.left; - var v1 = s1.key; - var d1 = s1.value; - var r1 = s1.right; - var match = split(v1, s2); - return Bs_internalAVLtree.concatOrJoin(merge(l1, match[0], f), v1, f(v1, /* Some */[d1], match[1]), merge(r1, match[2], f)); - } else { - exit = 1; - } - } else if (s2 !== null) { - exit = 1; - } else { - return null; - } - if (exit === 1) { - if (s2 !== null) { - var l2 = s2.left; - var v2 = s2.key; - var d2 = s2.value; - var r2 = s2.right; - var match$1 = split(v2, s1); - return Bs_internalAVLtree.concatOrJoin(merge(match$1[0], l2, f), v2, f(v2, match$1[1], /* Some */[d2]), merge(match$1[2], r2, f)); - } else { - return /* assert false */0; - } - } - -} - -function cmp(s1, s2, cmp$1) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var vcmp = cmp$1; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - var c = Caml_primitive.caml_int_compare(h1.key, h2.key); - if (c) { - return c; - } else { - var cx = vcmp(h1.value, h2.value); - if (cx) { - return cx; - } else { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } - } - } else { - return 0; - } - } else { - return 0; - } - }; - } else if (len1 < len2) { - return -1; - } else { - return 1; - } -} +var isEmpty = Bs_internalAVLtree.isEmpty0; -function eq(s1, s2, eq$1) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var eq$2 = eq$1; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - if (h1.key === h2.key && eq$2(h1.value, h2.value)) { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } else { - return /* false */0; - } - } else { - return /* true */1; - } - } else { - return /* true */1; - } - }; - } else { - return /* false */0; - } -} +var mem = Bs_internalMapInt.mem; -function ofArray(xs) { - var result = null; - for(var i = 0 ,i_finish = xs.length - 1 | 0; i <= i_finish; ++i){ - var match = xs[i]; - result = add(result, match[0], match[1]); - } - return result; -} +var singleton = Bs_internalAVLtree.singleton0; -var empty = Bs_internalAVLtree.empty0; +var merge = Bs_internalMapInt.merge; -var isEmpty = Bs_internalAVLtree.isEmpty0; +var cmp = Bs_internalMapInt.cmp; -var singleton = Bs_internalAVLtree.singleton0; +var eq = Bs_internalMapInt.eq; var iter = Bs_internalAVLtree.iter0; @@ -321,17 +101,31 @@ var forAll = Bs_internalAVLtree.forAll0; var exists = Bs_internalAVLtree.exists0; -var filter = Bs_internalAVLtree.filter0; +var filter = Bs_internalAVLtree.filterShared0; -var partition = Bs_internalAVLtree.partition0; +var partition = Bs_internalAVLtree.partitionShared0; var length = Bs_internalAVLtree.length0; var toList = Bs_internalAVLtree.toList0; -var minBinding = Bs_internalAVLtree.minKVOpt0; +var minKVOpt = Bs_internalAVLtree.minKVOpt0; + +var minKVNull = Bs_internalAVLtree.minKVNull0; + +var maxKVOpt = Bs_internalAVLtree.maxKVOpt0; + +var maxKVNull = Bs_internalAVLtree.maxKVNull0; + +var split = Bs_internalMapInt.split; + +var findOpt = Bs_internalMapInt.findOpt; + +var findNull = Bs_internalMapInt.findNull; + +var findWithDefault = Bs_internalMapInt.findWithDefault; -var maxBinding = Bs_internalAVLtree.maxKVOpt0; +var findExn = Bs_internalMapInt.findExn; var map = Bs_internalAVLtree.map0; @@ -343,7 +137,8 @@ exports.empty = empty; exports.ofArray = ofArray; exports.isEmpty = isEmpty; exports.mem = mem; -exports.add = add; +exports.update = update; +exports.updateWithOpt = updateWithOpt; exports.singleton = singleton; exports.remove = remove; exports.merge = merge; @@ -357,12 +152,15 @@ exports.filter = filter; exports.partition = partition; exports.length = length; exports.toList = toList; -exports.minBinding = minBinding; -exports.maxBinding = maxBinding; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; exports.split = split; exports.findOpt = findOpt; -exports.findAssert = findAssert; +exports.findNull = findNull; exports.findWithDefault = findWithDefault; +exports.findExn = findExn; exports.map = map; exports.mapi = mapi; exports.checkInvariant = checkInvariant; diff --git a/lib/js/bs_MapIntM.js b/lib/js/bs_MapIntM.js new file mode 100644 index 00000000000..c8541698a9e --- /dev/null +++ b/lib/js/bs_MapIntM.js @@ -0,0 +1,223 @@ +'use strict'; + +var Bs_internalMapInt = require("./bs_internalMapInt.js"); +var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); + +function empty() { + return { + data: Bs_internalAVLtree.empty0 + }; +} + +function isEmpty(m) { + return Bs_internalAVLtree.isEmpty0(m.data); +} + +function singleton(k, v) { + return { + data: Bs_internalAVLtree.singleton0(k, v) + }; +} + +function minKVOpt(m) { + return Bs_internalAVLtree.minKVOpt0(m.data); +} + +function minKVNull(m) { + return Bs_internalAVLtree.minKVNull0(m.data); +} + +function maxKVOpt(m) { + return Bs_internalAVLtree.maxKVOpt0(m.data); +} + +function maxKVNull(m) { + return Bs_internalAVLtree.maxKVNull0(m.data); +} + +function addOnly(m, k, v) { + var old_data = m.data; + var v$1 = Bs_internalMapInt.addMutate(old_data, k, v); + if (v$1 !== old_data) { + m.data = v$1; + return /* () */0; + } else { + return 0; + } +} + +function add(d, k, v) { + addOnly(d, k, v); + return d; +} + +function iter(d, f) { + return Bs_internalAVLtree.iter0(d.data, f); +} + +function map(d, f) { + return { + data: Bs_internalAVLtree.map0(d.data, f) + }; +} + +function mapi(d, f) { + return { + data: Bs_internalAVLtree.mapi0(d.data, f) + }; +} + +function fold(d, acc, f) { + return Bs_internalAVLtree.fold0(d.data, acc, f); +} + +function forAll(d, f) { + return Bs_internalAVLtree.forAll0(d.data, f); +} + +function exists(d, f) { + return Bs_internalAVLtree.exists0(d.data, f); +} + +function length(d) { + return Bs_internalAVLtree.length0(d.data); +} + +function toList(d) { + return Bs_internalAVLtree.toList0(d.data); +} + +function checkInvariant(d) { + return Bs_internalAVLtree.checkInvariant(d.data); +} + +function mem(d, v) { + return Bs_internalMapInt.mem(d.data, v); +} + +function removeMutateAux(nt, x) { + var k = nt.key; + if (x === k) { + var l = nt.left; + var r = nt.right; + if (l !== null) { + if (r !== null) { + nt.right = Bs_internalAVLtree.removeMinAuxWithRootMutate(nt, r); + return Bs_internalAVLtree.balMutate(nt); + } else { + return l; + } + } else if (r !== null) { + return r; + } else { + return l; + } + } else if (x < k) { + var match = nt.left; + if (match !== null) { + nt.left = removeMutateAux(match, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } else { + var match$1 = nt.right; + if (match$1 !== null) { + nt.right = removeMutateAux(match$1, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } +} + +function removeMutate(nt, x) { + if (nt !== null) { + return removeMutateAux(nt, x); + } else { + return nt; + } +} + +function removeOnly(d, v) { + var old_data = d.data; + var v$1 = removeMutate(old_data, v); + if (v$1 !== old_data) { + d.data = v$1; + return /* () */0; + } else { + return 0; + } +} + +function remove(d, v) { + removeOnly(d, v); + return d; +} + +function ofArray(xs) { + return { + data: Bs_internalMapInt.ofArray(xs) + }; +} + +function cmp(d0, d1) { + var partial_arg = d1.data; + var partial_arg$1 = d0.data; + return (function (param) { + return Bs_internalMapInt.cmp(partial_arg$1, partial_arg, param); + }); +} + +function eq(d0, d1) { + var partial_arg = d1.data; + var partial_arg$1 = d0.data; + return (function (param) { + return Bs_internalMapInt.eq(partial_arg$1, partial_arg, param); + }); +} + +function findOpt(d, x) { + return Bs_internalMapInt.findOpt(d.data, x); +} + +function findNull(d, x) { + return Bs_internalMapInt.findNull(d.data, x); +} + +function findWithDefault(d, x, def) { + return Bs_internalMapInt.findWithDefault(d.data, x, def); +} + +function findExn(d, x) { + return Bs_internalMapInt.findExn(d.data, x); +} + +exports.empty = empty; +exports.ofArray = ofArray; +exports.isEmpty = isEmpty; +exports.mem = mem; +exports.addOnly = addOnly; +exports.add = add; +exports.singleton = singleton; +exports.remove = remove; +exports.cmp = cmp; +exports.eq = eq; +exports.iter = iter; +exports.fold = fold; +exports.forAll = forAll; +exports.exists = exists; +exports.length = length; +exports.toList = toList; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; +exports.findOpt = findOpt; +exports.findNull = findNull; +exports.findWithDefault = findWithDefault; +exports.findExn = findExn; +exports.map = map; +exports.mapi = mapi; +exports.checkInvariant = checkInvariant; +/* No side effect */ diff --git a/lib/js/bs_MapM.js b/lib/js/bs_MapM.js new file mode 100644 index 00000000000..7e23c7ea2e0 --- /dev/null +++ b/lib/js/bs_MapM.js @@ -0,0 +1,239 @@ +'use strict'; + +var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); + +function removeMutateAux(cmp, nt, x) { + var k = nt.key; + var c = cmp(x, k); + if (c) { + if (c < 0) { + var match = nt.left; + if (match !== null) { + nt.left = removeMutateAux(cmp, match, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } else { + var match$1 = nt.right; + if (match$1 !== null) { + nt.right = removeMutateAux(cmp, match$1, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } + } else { + var l = nt.left; + var r = nt.right; + if (l !== null) { + if (r !== null) { + nt.right = Bs_internalAVLtree.removeMinAuxWithRootMutate(nt, r); + return Bs_internalAVLtree.balMutate(nt); + } else { + return l; + } + } else if (r !== null) { + return r; + } else { + return l; + } + } +} + +function removeOnly(d, k) { + var dict = d.dict; + var oldRoot = d.data; + if (oldRoot !== null) { + var newRoot = removeMutateAux(dict[/* cmp */0], oldRoot, k); + if (newRoot !== oldRoot) { + d.data = newRoot; + return /* () */0; + } else { + return 0; + } + } else { + return /* () */0; + } +} + +function remove(d, v) { + removeOnly(d, v); + return d; +} + +function empty(dict) { + return { + dict: dict, + data: Bs_internalAVLtree.empty0 + }; +} + +function isEmpty(d) { + return Bs_internalAVLtree.isEmpty0(d.data); +} + +function singleton(dict, x, v) { + return { + dict: dict, + data: Bs_internalAVLtree.singleton0(x, v) + }; +} + +function minKVOpt(m) { + return Bs_internalAVLtree.minKVOpt0(m.data); +} + +function minKVNull(m) { + return Bs_internalAVLtree.minKVNull0(m.data); +} + +function maxKVOpt(m) { + return Bs_internalAVLtree.maxKVOpt0(m.data); +} + +function maxKVNull(m) { + return Bs_internalAVLtree.maxKVNull0(m.data); +} + +function iter(d, f) { + return Bs_internalAVLtree.iter0(d.data, f); +} + +function fold(d, acc, cb) { + return Bs_internalAVLtree.fold0(d.data, acc, cb); +} + +function forAll(d, p) { + return Bs_internalAVLtree.forAll0(d.data, p); +} + +function exists(d, p) { + return Bs_internalAVLtree.exists0(d.data, p); +} + +function length(d) { + return Bs_internalAVLtree.length0(d.data); +} + +function toList(d) { + return Bs_internalAVLtree.toList0(d.data); +} + +function toArray(d) { + return Bs_internalAVLtree.toArray0(d.data); +} + +function addOnly(m, e, v) { + var dict = m.dict; + var oldRoot = m.data; + var newRoot = Bs_internalAVLtree.addMutate(dict[/* cmp */0], oldRoot, e, v); + if (newRoot !== oldRoot) { + m.data = newRoot; + return /* () */0; + } else { + return 0; + } +} + +function add(m, e, v) { + addOnly(m, e, v); + return m; +} + +function ofArray(dict, data) { + return { + dict: dict, + data: Bs_internalAVLtree.ofArray0(dict[/* cmp */0], data) + }; +} + +function cmp(m1, m2, cmp$1) { + var dict = m1.dict; + var m1_data = m1.data; + var m2_data = m2.data; + return Bs_internalAVLtree.cmp0(m1_data, m2_data, dict[/* cmp */0], cmp$1); +} + +function eq(m1, m2, cmp) { + var dict = m1.dict; + var m1_data = m1.data; + var m2_data = m2.data; + return Bs_internalAVLtree.eq0(m1_data, m2_data, dict[/* cmp */0], cmp); +} + +function map(m, f) { + var dict = m.dict; + var map$1 = m.data; + return { + dict: dict, + data: Bs_internalAVLtree.map0(map$1, f) + }; +} + +function mapi(map, f) { + var dict = map.dict; + var map$1 = map.data; + return { + dict: dict, + data: Bs_internalAVLtree.mapi0(map$1, f) + }; +} + +function findOpt(map, x) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.findOpt0(map$1, x, dict[/* cmp */0]); +} + +function findNull(map, x) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.findNull0(map$1, x, dict[/* cmp */0]); +} + +function findWithDefault(map, x, def) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.findWithDefault0(map$1, x, def, dict[/* cmp */0]); +} + +function findExn(map, x) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.findExn0(map$1, x, dict[/* cmp */0]); +} + +function mem(map, x) { + var dict = map.dict; + var map$1 = map.data; + return Bs_internalAVLtree.mem0(map$1, x, dict[/* cmp */0]); +} + +exports.empty = empty; +exports.ofArray = ofArray; +exports.isEmpty = isEmpty; +exports.mem = mem; +exports.add = add; +exports.singleton = singleton; +exports.remove = remove; +exports.cmp = cmp; +exports.eq = eq; +exports.iter = iter; +exports.fold = fold; +exports.forAll = forAll; +exports.exists = exists; +exports.length = length; +exports.toList = toList; +exports.toArray = toArray; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; +exports.findOpt = findOpt; +exports.findNull = findNull; +exports.findWithDefault = findWithDefault; +exports.findExn = findExn; +exports.map = map; +exports.mapi = mapi; +/* No side effect */ diff --git a/lib/js/bs_MapString.js b/lib/js/bs_MapString.js index 517bc22d1af..9ab90bfe533 100644 --- a/lib/js/bs_MapString.js +++ b/lib/js/bs_MapString.js @@ -1,108 +1,52 @@ 'use strict'; -var Caml_primitive = require("./caml_primitive.js"); var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); +var Bs_internalMapString = require("./bs_internalMapString.js"); -function add(t, x, data) { +function update(t, newK, newD) { if (t !== null) { - var l = t.left; var k = t.key; - var v = t.value; - var r = t.right; - if (x === k) { - return { - left: l, - key: x, - value: data, - right: r, - h: t.h - }; - } else if (x < k) { - return Bs_internalAVLtree.bal(add(l, x, data), k, v, r); + if (newK === k) { + return Bs_internalAVLtree.updateKV(t, newK, newD); } else { - return Bs_internalAVLtree.bal(l, k, v, add(r, x, data)); - } - } else { - return { - left: null, - key: x, - value: data, - right: null, - h: 1 - }; - } -} - -function findOpt(x, _n) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return /* Some */[n.value]; + var v = t.value; + if (newK < k) { + return Bs_internalAVLtree.bal(update(t.left, newK, newD), k, v, t.right); } else { - _n = x < v ? n.left : n.right; - continue ; - + return Bs_internalAVLtree.bal(t.left, k, v, update(t.right, newK, newD)); } - } else { - return /* None */0; } - }; + } else { + return Bs_internalAVLtree.singleton0(newK, newD); + } } -function findAssert(x, _n) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return n.value; +function updateWithOpt(t, x, f) { + if (t !== null) { + var k = t.key; + if (x === k) { + var match = f(/* Some */[k]); + if (match) { + return Bs_internalAVLtree.updateKV(t, x, match[0]); } else { - _n = x < v ? n.left : n.right; - continue ; - + return t; } } else { - throw new Error("Not_found"); - } - }; -} - -function findWithDefault(_n, x, def) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return n.value; + var v = t.value; + if (x < k) { + return Bs_internalAVLtree.bal(updateWithOpt(t.left, x, f), k, v, t.right); } else { - _n = x < v ? n.left : n.right; - continue ; - + return Bs_internalAVLtree.bal(t.left, k, v, updateWithOpt(t.right, x, f)); } - } else { - return def; } - }; -} - -function mem(_n, x) { - while(true) { - var n = _n; - if (n !== null) { - var v = n.key; - if (x === v) { - return /* true */1; - } else { - _n = x < v ? n.left : n.right; - continue ; - - } + } else { + var match$1 = f(/* None */0); + if (match$1) { + return Bs_internalAVLtree.singleton0(x, match$1[0]); } else { - return /* false */0; + return t; } - }; + } } function remove(n, x) { @@ -133,185 +77,21 @@ function remove(n, x) { } } -function splitAux(x, n) { - var l = n.left; - var v = n.key; - var d = n.value; - var r = n.right; - if (x === v) { - return /* tuple */[ - l, - /* Some */[d], - r - ]; - } else if (x < v) { - if (l !== null) { - var match = splitAux(x, l); - return /* tuple */[ - match[0], - match[1], - Bs_internalAVLtree.join(match[2], v, d, r) - ]; - } else { - return /* tuple */[ - null, - /* None */0, - n - ]; - } - } else if (r !== null) { - var match$1 = splitAux(x, r); - return /* tuple */[ - Bs_internalAVLtree.join(l, v, d, match$1[0]), - match$1[1], - match$1[2] - ]; - } else { - return /* tuple */[ - n, - /* None */0, - null - ]; - } -} +var empty = Bs_internalAVLtree.empty0; -function split(x, n) { - if (n !== null) { - return splitAux(x, n); - } else { - return /* tuple */[ - null, - /* None */0, - null - ]; - } -} +var ofArray = Bs_internalMapString.ofArray; -function merge(s1, s2, f) { - var exit = 0; - if (s1 !== null) { - if (s1.h >= ( - s2 !== null ? s2.h : 0 - )) { - var l1 = s1.left; - var v1 = s1.key; - var d1 = s1.value; - var r1 = s1.right; - var match = split(v1, s2); - return Bs_internalAVLtree.concatOrJoin(merge(l1, match[0], f), v1, f(v1, /* Some */[d1], match[1]), merge(r1, match[2], f)); - } else { - exit = 1; - } - } else if (s2 !== null) { - exit = 1; - } else { - return null; - } - if (exit === 1) { - if (s2 !== null) { - var l2 = s2.left; - var v2 = s2.key; - var d2 = s2.value; - var r2 = s2.right; - var match$1 = split(v2, s1); - return Bs_internalAVLtree.concatOrJoin(merge(match$1[0], l2, f), v2, f(v2, match$1[1], /* Some */[d2]), merge(match$1[2], r2, f)); - } else { - return /* assert false */0; - } - } - -} - -function cmp(s1, s2, cmp$1) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var vcmp = cmp$1; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - var c = Caml_primitive.caml_string_compare(h1.key, h2.key); - if (c) { - return c; - } else { - var cx = vcmp(h1.value, h2.value); - if (cx) { - return cx; - } else { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } - } - } else { - return 0; - } - } else { - return 0; - } - }; - } else if (len1 < len2) { - return -1; - } else { - return 1; - } -} +var isEmpty = Bs_internalAVLtree.isEmpty0; -function eq(s1, s2, eq$1) { - var len1 = Bs_internalAVLtree.length0(s1); - var len2 = Bs_internalAVLtree.length0(s2); - if (len1 === len2) { - var _e1 = Bs_internalAVLtree.stackAllLeft(s1, /* [] */0); - var _e2 = Bs_internalAVLtree.stackAllLeft(s2, /* [] */0); - var eq$2 = eq$1; - while(true) { - var e2 = _e2; - var e1 = _e1; - if (e1) { - if (e2) { - var h2 = e2[0]; - var h1 = e1[0]; - if (h1.key === h2.key && eq$2(h1.value, h2.value)) { - _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); - _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); - continue ; - - } else { - return /* false */0; - } - } else { - return /* true */1; - } - } else { - return /* true */1; - } - }; - } else { - return /* false */0; - } -} +var mem = Bs_internalMapString.mem; -function ofArray(xs) { - var result = null; - for(var i = 0 ,i_finish = xs.length - 1 | 0; i <= i_finish; ++i){ - var match = xs[i]; - result = add(result, match[0], match[1]); - } - return result; -} +var singleton = Bs_internalAVLtree.singleton0; -var empty = Bs_internalAVLtree.empty0; +var merge = Bs_internalMapString.merge; -var isEmpty = Bs_internalAVLtree.isEmpty0; +var cmp = Bs_internalMapString.cmp; -var singleton = Bs_internalAVLtree.singleton0; +var eq = Bs_internalMapString.eq; var iter = Bs_internalAVLtree.iter0; @@ -321,17 +101,31 @@ var forAll = Bs_internalAVLtree.forAll0; var exists = Bs_internalAVLtree.exists0; -var filter = Bs_internalAVLtree.filter0; +var filter = Bs_internalAVLtree.filterShared0; -var partition = Bs_internalAVLtree.partition0; +var partition = Bs_internalAVLtree.partitionShared0; var length = Bs_internalAVLtree.length0; var toList = Bs_internalAVLtree.toList0; -var minBinding = Bs_internalAVLtree.minKVOpt0; +var minKVOpt = Bs_internalAVLtree.minKVOpt0; + +var minKVNull = Bs_internalAVLtree.minKVNull0; + +var maxKVOpt = Bs_internalAVLtree.maxKVOpt0; + +var maxKVNull = Bs_internalAVLtree.maxKVNull0; + +var split = Bs_internalMapString.split; + +var findOpt = Bs_internalMapString.findOpt; + +var findNull = Bs_internalMapString.findNull; + +var findWithDefault = Bs_internalMapString.findWithDefault; -var maxBinding = Bs_internalAVLtree.maxKVOpt0; +var findExn = Bs_internalMapString.findExn; var map = Bs_internalAVLtree.map0; @@ -343,7 +137,8 @@ exports.empty = empty; exports.ofArray = ofArray; exports.isEmpty = isEmpty; exports.mem = mem; -exports.add = add; +exports.update = update; +exports.updateWithOpt = updateWithOpt; exports.singleton = singleton; exports.remove = remove; exports.merge = merge; @@ -357,12 +152,15 @@ exports.filter = filter; exports.partition = partition; exports.length = length; exports.toList = toList; -exports.minBinding = minBinding; -exports.maxBinding = maxBinding; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; exports.split = split; exports.findOpt = findOpt; -exports.findAssert = findAssert; +exports.findNull = findNull; exports.findWithDefault = findWithDefault; +exports.findExn = findExn; exports.map = map; exports.mapi = mapi; exports.checkInvariant = checkInvariant; diff --git a/lib/js/bs_MapStringM.js b/lib/js/bs_MapStringM.js new file mode 100644 index 00000000000..117f6f54d6e --- /dev/null +++ b/lib/js/bs_MapStringM.js @@ -0,0 +1,223 @@ +'use strict'; + +var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); +var Bs_internalMapString = require("./bs_internalMapString.js"); + +function empty() { + return { + data: Bs_internalAVLtree.empty0 + }; +} + +function isEmpty(m) { + return Bs_internalAVLtree.isEmpty0(m.data); +} + +function singleton(k, v) { + return { + data: Bs_internalAVLtree.singleton0(k, v) + }; +} + +function minKVOpt(m) { + return Bs_internalAVLtree.minKVOpt0(m.data); +} + +function minKVNull(m) { + return Bs_internalAVLtree.minKVNull0(m.data); +} + +function maxKVOpt(m) { + return Bs_internalAVLtree.maxKVOpt0(m.data); +} + +function maxKVNull(m) { + return Bs_internalAVLtree.maxKVNull0(m.data); +} + +function addOnly(m, k, v) { + var old_data = m.data; + var v$1 = Bs_internalMapString.addMutate(old_data, k, v); + if (v$1 !== old_data) { + m.data = v$1; + return /* () */0; + } else { + return 0; + } +} + +function add(d, k, v) { + addOnly(d, k, v); + return d; +} + +function iter(d, f) { + return Bs_internalAVLtree.iter0(d.data, f); +} + +function map(d, f) { + return { + data: Bs_internalAVLtree.map0(d.data, f) + }; +} + +function mapi(d, f) { + return { + data: Bs_internalAVLtree.mapi0(d.data, f) + }; +} + +function fold(d, acc, f) { + return Bs_internalAVLtree.fold0(d.data, acc, f); +} + +function forAll(d, f) { + return Bs_internalAVLtree.forAll0(d.data, f); +} + +function exists(d, f) { + return Bs_internalAVLtree.exists0(d.data, f); +} + +function length(d) { + return Bs_internalAVLtree.length0(d.data); +} + +function toList(d) { + return Bs_internalAVLtree.toList0(d.data); +} + +function checkInvariant(d) { + return Bs_internalAVLtree.checkInvariant(d.data); +} + +function mem(d, v) { + return Bs_internalMapString.mem(d.data, v); +} + +function removeMutateAux(nt, x) { + var k = nt.key; + if (x === k) { + var l = nt.left; + var r = nt.right; + if (l !== null) { + if (r !== null) { + nt.right = Bs_internalAVLtree.removeMinAuxWithRootMutate(nt, r); + return Bs_internalAVLtree.balMutate(nt); + } else { + return l; + } + } else if (r !== null) { + return r; + } else { + return l; + } + } else if (x < k) { + var match = nt.left; + if (match !== null) { + nt.left = removeMutateAux(match, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } else { + var match$1 = nt.right; + if (match$1 !== null) { + nt.right = removeMutateAux(match$1, x); + return Bs_internalAVLtree.balMutate(nt); + } else { + return nt; + } + } +} + +function removeMutate(nt, x) { + if (nt !== null) { + return removeMutateAux(nt, x); + } else { + return nt; + } +} + +function removeOnly(d, v) { + var old_data = d.data; + var v$1 = removeMutate(old_data, v); + if (v$1 !== old_data) { + d.data = v$1; + return /* () */0; + } else { + return 0; + } +} + +function remove(d, v) { + removeOnly(d, v); + return d; +} + +function ofArray(xs) { + return { + data: Bs_internalMapString.ofArray(xs) + }; +} + +function cmp(d0, d1) { + var partial_arg = d1.data; + var partial_arg$1 = d0.data; + return (function (param) { + return Bs_internalMapString.cmp(partial_arg$1, partial_arg, param); + }); +} + +function eq(d0, d1) { + var partial_arg = d1.data; + var partial_arg$1 = d0.data; + return (function (param) { + return Bs_internalMapString.eq(partial_arg$1, partial_arg, param); + }); +} + +function findOpt(d, x) { + return Bs_internalMapString.findOpt(d.data, x); +} + +function findNull(d, x) { + return Bs_internalMapString.findNull(d.data, x); +} + +function findWithDefault(d, x, def) { + return Bs_internalMapString.findWithDefault(d.data, x, def); +} + +function findExn(d, x) { + return Bs_internalMapString.findExn(d.data, x); +} + +exports.empty = empty; +exports.ofArray = ofArray; +exports.isEmpty = isEmpty; +exports.mem = mem; +exports.addOnly = addOnly; +exports.add = add; +exports.singleton = singleton; +exports.remove = remove; +exports.cmp = cmp; +exports.eq = eq; +exports.iter = iter; +exports.fold = fold; +exports.forAll = forAll; +exports.exists = exists; +exports.length = length; +exports.toList = toList; +exports.minKVOpt = minKVOpt; +exports.minKVNull = minKVNull; +exports.maxKVOpt = maxKVOpt; +exports.maxKVNull = maxKVNull; +exports.findOpt = findOpt; +exports.findNull = findNull; +exports.findWithDefault = findWithDefault; +exports.findExn = findExn; +exports.map = map; +exports.mapi = mapi; +exports.checkInvariant = checkInvariant; +/* No side effect */ diff --git a/lib/js/bs_Set.js b/lib/js/bs_Set.js index a66fcab6347..dac2691bfe5 100644 --- a/lib/js/bs_Set.js +++ b/lib/js/bs_Set.js @@ -2,7 +2,7 @@ var Bs_internalAVLset = require("./bs_internalAVLset.js"); -function add0(cmp, t, x) { +function add0(t, x, cmp) { if (t !== null) { var k = t.key; var c = cmp(x, k); @@ -10,14 +10,14 @@ function add0(cmp, t, x) { var l = t.left; var r = t.right; if (c < 0) { - var ll = add0(cmp, l, x); + var ll = add0(l, x, cmp); if (ll === l) { return t; } else { return Bs_internalAVLset.bal(ll, k, r); } } else { - var rr = add0(cmp, r, x); + var rr = add0(r, x, cmp); if (rr === r) { return t; } else { @@ -32,7 +32,7 @@ function add0(cmp, t, x) { } } -function remove0(cmp, t, x) { +function remove0(t, x, cmp) { if (t !== null) { var l = t.left; var v = t.key; @@ -40,14 +40,14 @@ function remove0(cmp, t, x) { var c = cmp(x, v); if (c) { if (c < 0) { - var ll = remove0(cmp, l, x); + var ll = remove0(l, x, cmp); if (ll === l) { return t; } else { return Bs_internalAVLset.bal(ll, v, r); } } else { - var rr = remove0(cmp, r, x); + var rr = remove0(r, x, cmp); if (rr === r) { return t; } else { @@ -75,7 +75,7 @@ function addArray0(h, arr, cmp) { var v = h; for(var i = 0 ,i_finish = len - 1 | 0; i <= i_finish; ++i){ var key = arr[i]; - v = add0(cmp, v, key); + v = add0(v, key, cmp); } return v; } @@ -85,7 +85,7 @@ function removeArray0(h, arr, cmp) { var v = h; for(var i = 0 ,i_finish = len - 1 | 0; i <= i_finish; ++i){ var key = arr[i]; - v = remove0(cmp, v, key); + v = remove0(v, key, cmp); } return v; } @@ -195,7 +195,7 @@ function union0(cmp, s1, s2) { var h2 = s2.h; if (h1 >= h2) { if (h2 === 1) { - return add0(cmp, s1, s2.key); + return add0(s1, s2.key, cmp); } else { var l1 = s1.left; var v1 = s1.key; @@ -204,7 +204,7 @@ function union0(cmp, s1, s2) { return Bs_internalAVLset.joinShared(union0(cmp, l1, match[0]), v1, union0(cmp, r1, match[1])); } } else if (h1 === 1) { - return add0(cmp, s2, s1.key); + return add0(s2, s1.key, cmp); } else { var l2 = s2.left; var v2 = s2.key; @@ -293,7 +293,7 @@ function mem(m, e) { function add(m, e) { var dict = m.dict; var data = m.data; - var newData = add0(dict[/* cmp */0], data, e); + var newData = add0(data, e, dict[/* cmp */0]); if (newData === data) { return m; } else { @@ -342,7 +342,7 @@ function singleton(dict, e) { function remove(m, e) { var dict = m.dict; var data = m.data; - var newData = remove0(dict[/* cmp */0], data, e); + var newData = remove0(data, e, dict[/* cmp */0]); if (newData === data) { return m; } else { diff --git a/lib/js/bs_SetInt.js b/lib/js/bs_SetInt.js index 2f9cb9623ae..090054838d5 100644 --- a/lib/js/bs_SetInt.js +++ b/lib/js/bs_SetInt.js @@ -3,6 +3,72 @@ var Bs_internalAVLset = require("./bs_internalAVLset.js"); var Bs_internalSetInt = require("./bs_internalSetInt.js"); +function add(t, x) { + if (t !== null) { + var v = t.key; + if (x === v) { + return t; + } else { + var l = t.left; + var r = t.right; + if (x < v) { + var ll = add(l, x); + if (ll === l) { + return t; + } else { + return Bs_internalAVLset.bal(ll, v, r); + } + } else { + var rr = add(r, x); + if (rr === r) { + return t; + } else { + return Bs_internalAVLset.bal(l, v, add(r, x)); + } + } + } + } else { + return Bs_internalAVLset.singleton0(x); + } +} + +function remove(t, x) { + if (t !== null) { + var l = t.left; + var v = t.key; + var r = t.right; + if (x === v) { + if (l !== null) { + if (r !== null) { + var v$1 = [r.key]; + var r$1 = Bs_internalAVLset.removeMinAuxWithRef(r, v$1); + return Bs_internalAVLset.bal(l, v$1[0], r$1); + } else { + return l; + } + } else { + return r; + } + } else if (x < v) { + var ll = remove(l, x); + if (ll === l) { + return t; + } else { + return Bs_internalAVLset.bal(ll, v, r); + } + } else { + var rr = remove(r, x); + if (rr === r) { + return t; + } else { + return Bs_internalAVLset.bal(l, v, rr); + } + } + } else { + return t; + } +} + function splitAuxNoPivot(n, x) { var l = n.left; var v = n.key; @@ -102,7 +168,7 @@ function union(s1, s2) { var h2 = s2.h; if (h1 >= h2) { if (h2 === 1) { - return Bs_internalSetInt.add(s1, s2.key); + return add(s1, s2.key); } else { var l1 = s1.left; var v1 = s1.key; @@ -111,7 +177,7 @@ function union(s1, s2) { return Bs_internalAVLset.joinShared(union(l1, match[0]), v1, union(r1, match[1])); } } else if (h1 === 1) { - return Bs_internalSetInt.add(s2, s1.key); + return add(s2, s1.key); } else { var l2 = s2.left; var v2 = s2.key; @@ -179,12 +245,8 @@ var isEmpty = Bs_internalAVLset.isEmpty0; var mem = Bs_internalSetInt.mem; -var add = Bs_internalSetInt.add; - var singleton = Bs_internalAVLset.singleton0; -var remove = Bs_internalSetInt.remove; - var cmp = Bs_internalSetInt.cmp; var eq = Bs_internalSetInt.eq; diff --git a/lib/js/bs_SetIntM.js b/lib/js/bs_SetIntM.js index 241ef7ab229..95f88ae39e4 100644 --- a/lib/js/bs_SetIntM.js +++ b/lib/js/bs_SetIntM.js @@ -360,8 +360,8 @@ function mem(d, x) { exports.empty = empty; exports.isEmpty = isEmpty; exports.mem = mem; -exports.add = add; exports.addOnly = addOnly; +exports.add = add; exports.singleton = singleton; exports.remove = remove; exports.removeOnly = removeOnly; diff --git a/lib/js/bs_SetString.js b/lib/js/bs_SetString.js index 1b4609c0d6c..56cdf7ddbe6 100644 --- a/lib/js/bs_SetString.js +++ b/lib/js/bs_SetString.js @@ -3,6 +3,72 @@ var Bs_internalAVLset = require("./bs_internalAVLset.js"); var Bs_internalSetString = require("./bs_internalSetString.js"); +function add(t, x) { + if (t !== null) { + var v = t.key; + if (x === v) { + return t; + } else { + var l = t.left; + var r = t.right; + if (x < v) { + var ll = add(l, x); + if (ll === l) { + return t; + } else { + return Bs_internalAVLset.bal(ll, v, r); + } + } else { + var rr = add(r, x); + if (rr === r) { + return t; + } else { + return Bs_internalAVLset.bal(l, v, add(r, x)); + } + } + } + } else { + return Bs_internalAVLset.singleton0(x); + } +} + +function remove(t, x) { + if (t !== null) { + var l = t.left; + var v = t.key; + var r = t.right; + if (x === v) { + if (l !== null) { + if (r !== null) { + var v$1 = [r.key]; + var r$1 = Bs_internalAVLset.removeMinAuxWithRef(r, v$1); + return Bs_internalAVLset.bal(l, v$1[0], r$1); + } else { + return l; + } + } else { + return r; + } + } else if (x < v) { + var ll = remove(l, x); + if (ll === l) { + return t; + } else { + return Bs_internalAVLset.bal(ll, v, r); + } + } else { + var rr = remove(r, x); + if (rr === r) { + return t; + } else { + return Bs_internalAVLset.bal(l, v, rr); + } + } + } else { + return t; + } +} + function splitAuxNoPivot(n, x) { var l = n.left; var v = n.key; @@ -102,7 +168,7 @@ function union(s1, s2) { var h2 = s2.h; if (h1 >= h2) { if (h2 === 1) { - return Bs_internalSetString.add(s1, s2.key); + return add(s1, s2.key); } else { var l1 = s1.left; var v1 = s1.key; @@ -111,7 +177,7 @@ function union(s1, s2) { return Bs_internalAVLset.joinShared(union(l1, match[0]), v1, union(r1, match[1])); } } else if (h1 === 1) { - return Bs_internalSetString.add(s2, s1.key); + return add(s2, s1.key); } else { var l2 = s2.left; var v2 = s2.key; @@ -179,12 +245,8 @@ var isEmpty = Bs_internalAVLset.isEmpty0; var mem = Bs_internalSetString.mem; -var add = Bs_internalSetString.add; - var singleton = Bs_internalAVLset.singleton0; -var remove = Bs_internalSetString.remove; - var cmp = Bs_internalSetString.cmp; var eq = Bs_internalSetString.eq; diff --git a/lib/js/bs_SetStringM.js b/lib/js/bs_SetStringM.js index dcff4d32ba9..229538e2bcb 100644 --- a/lib/js/bs_SetStringM.js +++ b/lib/js/bs_SetStringM.js @@ -360,8 +360,8 @@ function mem(d, x) { exports.empty = empty; exports.isEmpty = isEmpty; exports.mem = mem; -exports.add = add; exports.addOnly = addOnly; +exports.add = add; exports.singleton = singleton; exports.remove = remove; exports.removeOnly = removeOnly; diff --git a/lib/js/bs_Sort.js b/lib/js/bs_Sort.js index 5a0f2aff9b7..10d74a10825 100644 --- a/lib/js/bs_Sort.js +++ b/lib/js/bs_Sort.js @@ -2,6 +2,64 @@ var Caml_array = require("./caml_array.js"); +function sortedLengthAuxMore(xs, _prec, _acc, len, lt) { + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len) { + return acc; + } else { + var v = xs[acc]; + if (lt(v, prec)) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; +} + +function strictlySortedLength(xs, lt) { + var len = xs.length; + if (len === 0 || len === 1) { + return len; + } else { + var x0 = xs[0]; + var x1 = xs[1]; + if (lt(x0, x1)) { + var xs$1 = xs; + var _prec = x1; + var _acc = 2; + var len$1 = len; + var lt$1 = lt; + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len$1) { + return acc; + } else { + var v = xs$1[acc]; + if (lt$1(prec, v)) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; + } else if (lt(x1, x0)) { + return -sortedLengthAuxMore(xs, x1, 2, len, lt) | 0; + } else { + return 1; + } + } +} + function isSorted(a, cmp) { var len = a.length; if (len) { @@ -352,6 +410,7 @@ function binSearch(sorted, key, cmp) { } } +exports.strictlySortedLength = strictlySortedLength; exports.isSorted = isSorted; exports.stableSortBy = stableSortBy; exports.union = union; diff --git a/lib/js/bs_SortInt.js b/lib/js/bs_SortInt.js index 8f8097fca0d..66094e628d9 100644 --- a/lib/js/bs_SortInt.js +++ b/lib/js/bs_SortInt.js @@ -2,6 +2,63 @@ var Caml_array = require("./caml_array.js"); +function sortedLengthAuxMore(xs, _prec, _acc, len) { + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len) { + return acc; + } else { + var v = xs[acc]; + if (prec > v) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; +} + +function strictlySortedLength(xs) { + var len = xs.length; + if (len === 0 || len === 1) { + return len; + } else { + var x0 = xs[0]; + var x1 = xs[1]; + if (x0 < x1) { + var xs$1 = xs; + var _prec = x1; + var _acc = 2; + var len$1 = len; + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len$1) { + return acc; + } else { + var v = xs$1[acc]; + if (prec < v) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; + } else if (x0 > x1) { + return -sortedLengthAuxMore(xs, x1, 2, len) | 0; + } else { + return 1; + } + } +} + function isSorted(a) { var len = a.length; if (len) { @@ -337,6 +394,7 @@ function binSearch(sorted, key) { } } +exports.strictlySortedLength = strictlySortedLength; exports.isSorted = isSorted; exports.stableSort = stableSort; exports.binSearch = binSearch; diff --git a/lib/js/bs_SortString.js b/lib/js/bs_SortString.js index 8f8097fca0d..66094e628d9 100644 --- a/lib/js/bs_SortString.js +++ b/lib/js/bs_SortString.js @@ -2,6 +2,63 @@ var Caml_array = require("./caml_array.js"); +function sortedLengthAuxMore(xs, _prec, _acc, len) { + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len) { + return acc; + } else { + var v = xs[acc]; + if (prec > v) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; +} + +function strictlySortedLength(xs) { + var len = xs.length; + if (len === 0 || len === 1) { + return len; + } else { + var x0 = xs[0]; + var x1 = xs[1]; + if (x0 < x1) { + var xs$1 = xs; + var _prec = x1; + var _acc = 2; + var len$1 = len; + while(true) { + var acc = _acc; + var prec = _prec; + if (acc >= len$1) { + return acc; + } else { + var v = xs$1[acc]; + if (prec < v) { + _acc = acc + 1 | 0; + _prec = v; + continue ; + + } else { + return acc; + } + } + }; + } else if (x0 > x1) { + return -sortedLengthAuxMore(xs, x1, 2, len) | 0; + } else { + return 1; + } + } +} + function isSorted(a) { var len = a.length; if (len) { @@ -337,6 +394,7 @@ function binSearch(sorted, key) { } } +exports.strictlySortedLength = strictlySortedLength; exports.isSorted = isSorted; exports.stableSort = stableSort; exports.binSearch = binSearch; diff --git a/lib/js/bs_internalAVLset.js b/lib/js/bs_internalAVLset.js index 3be778b0cd9..2676ad2d825 100644 --- a/lib/js/bs_internalAVLset.js +++ b/lib/js/bs_internalAVLset.js @@ -1,5 +1,6 @@ 'use strict'; +var Bs_Sort = require("./bs_Sort.js"); function height(n) { if (n !== null) { @@ -769,26 +770,6 @@ function findNull0(cmp, _n, x) { }; } -function sortedLengthAux(cmp, xs, _prec, _acc, len) { - while(true) { - var acc = _acc; - var prec = _prec; - if (acc >= len) { - return acc; - } else { - var v = xs[acc]; - if (cmp(v, prec) >= 0) { - _acc = acc + 1 | 0; - _prec = v; - continue ; - - } else { - return acc; - } - } - }; -} - function rotateWithLeftChild(k2) { var k1 = k2.left; k2.left = k1.right; @@ -898,8 +879,16 @@ function addMutate(cmp, t, x) { function ofArray0(cmp, xs) { var len = xs.length; if (len) { - var next = sortedLengthAux(cmp, xs, xs[0], 1, len); - var result = ofSortedArrayAux(xs, 0, next); + var next = Bs_Sort.strictlySortedLength(xs, (function (x, y) { + return +(cmp(x, y) < 0); + })); + var result; + if (next >= 0) { + result = ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = ofSortedArrayRevAux(xs, next - 1 | 0, next); + } for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ result = addMutate(cmp, result, xs[i]); } @@ -950,6 +939,7 @@ exports.checkInvariant = checkInvariant; exports.fillArray = fillArray; exports.toArray0 = toArray0; exports.ofSortedArrayAux = ofSortedArrayAux; +exports.ofSortedArrayRevAux = ofSortedArrayRevAux; exports.ofSortedArrayUnsafe0 = ofSortedArrayUnsafe0; exports.mem0 = mem0; exports.cmp0 = cmp0; diff --git a/lib/js/bs_internalAVLtree.js b/lib/js/bs_internalAVLtree.js index 3652534bcd9..ae4afd5eef4 100644 --- a/lib/js/bs_internalAVLtree.js +++ b/lib/js/bs_internalAVLtree.js @@ -1,5 +1,6 @@ 'use strict'; +var Bs_Sort = require("./bs_Sort.js"); function height(n) { if (n !== null) { @@ -47,6 +48,28 @@ function singleton0(x, d) { }; } +function heightGe(l, r) { + if (r !== null) { + if (l !== null) { + return +(l.h >= r.h); + } else { + return /* false */0; + } + } else { + return /* true */1; + } +} + +function updateKV(n, key, value) { + return { + left: n.left, + key: key, + value: value, + right: n.right, + h: n.h + }; +} + function bal(l, x, d, r) { var hl = l !== null ? l.h : 0; var hr = r !== null ? r.h : 0; @@ -373,32 +396,49 @@ function concatOrJoin(t1, v, d, t2) { } } -function filter0(p, n) { +function filterShared0(p, n) { if (n !== null) { var v = n.key; var d = n.value; - var newLeft = filter0(p, n.left); + var newLeft = filterShared0(p, n.left); var pvd = p(v, d); - var newRight = filter0(p, n.right); + var newRight = filterShared0(p, n.right); if (pvd) { return join(newLeft, v, d, newRight); } else { return concat(newLeft, newRight); } } else { - return n; + return null; + } +} + +function filterMap0(n, p) { + if (n !== null) { + var v = n.key; + var d = n.value; + var newLeft = filterMap0(n.left, p); + var pvd = p(v, d); + var newRight = filterMap0(n.right, p); + if (pvd) { + return join(newLeft, v, pvd[0], newRight); + } else { + return concat(newLeft, newRight); + } + } else { + return null; } } -function partition0(p, n) { +function partitionShared0(p, n) { if (n !== null) { var key = n.key; var value = n.value; - var match = partition0(p, n.left); + var match = partitionShared0(p, n.left); var lf = match[1]; var lt = match[0]; var pvd = p(key, value); - var match$1 = partition0(p, n.right); + var match$1 = partitionShared0(p, n.right); var rf = match$1[1]; var rt = match$1[0]; if (pvd) { @@ -489,6 +529,47 @@ function checkInvariant(_v) { }; } +function fillArrayKey(_n, _i, arr) { + while(true) { + var i = _i; + var n = _n; + var l = n.left; + var v = n.key; + var r = n.right; + var next = l !== null ? fillArrayKey(l, i, arr) : i; + arr[next] = v; + var rnext = next + 1 | 0; + if (r !== null) { + _i = rnext; + _n = r; + continue ; + + } else { + return rnext; + } + }; +} + +function fillArrayValue(_n, _i, arr) { + while(true) { + var i = _i; + var n = _n; + var l = n.left; + var r = n.right; + var next = l !== null ? fillArrayValue(l, i, arr) : i; + arr[next] = n.value; + var rnext = next + 1 | 0; + if (r !== null) { + _i = rnext; + _n = r; + continue ; + + } else { + return rnext; + } + }; +} + function fillArray(_n, _i, arr) { while(true) { var i = _i; @@ -524,6 +605,73 @@ function toArray0(n) { } } +function keysToArray0(n) { + if (n !== null) { + var size = lengthNode(n); + var v = new Array(size); + fillArrayKey(n, 0, v); + return v; + } else { + return /* array */[]; + } +} + +function valuesToArray0(n) { + if (n !== null) { + var size = lengthNode(n); + var v = new Array(size); + fillArrayValue(n, 0, v); + return v; + } else { + return /* array */[]; + } +} + +function ofSortedArrayRevAux(arr, off, len) { + if (len > 3 || len < 0) { + var nl = len / 2 | 0; + var left = ofSortedArrayRevAux(arr, off, nl); + var match = arr[off - nl | 0]; + var right = ofSortedArrayRevAux(arr, (off - nl | 0) - 1 | 0, (len - nl | 0) - 1 | 0); + return create(left, match[0], match[1], right); + } else { + switch (len) { + case 0 : + return empty0; + case 1 : + var match$1 = arr[off]; + return singleton0(match$1[0], match$1[1]); + case 2 : + var match_000 = arr[off]; + var match_001 = arr[off - 1 | 0]; + var match$2 = match_001; + var match$3 = match_000; + return { + left: singleton0(match$3[0], match$3[1]), + key: match$2[0], + value: match$2[1], + right: empty0, + h: 2 + }; + case 3 : + var match_000$1 = arr[off]; + var match_001$1 = arr[off - 1 | 0]; + var match_002 = arr[off - 2 | 0]; + var match$4 = match_002; + var match$5 = match_001$1; + var match$6 = match_000$1; + return { + left: singleton0(match$6[0], match$6[1]), + key: match$5[0], + value: match$5[1], + right: singleton0(match$4[0], match$4[1]), + h: 2 + }; + + } + } +} + function ofSortedArrayAux(arr, off, len) { if (len > 3 || len < 0) { var nl = len / 2 | 0; @@ -573,10 +721,327 @@ function ofSortedArrayUnsafe0(arr) { return ofSortedArrayAux(arr, 0, arr.length); } +function cmp0(s1, s2, kcmp, vcmp) { + var len1 = length0(s1); + var len2 = length0(s2); + if (len1 === len2) { + var _e1 = stackAllLeft(s1, /* [] */0); + var _e2 = stackAllLeft(s2, /* [] */0); + var kcmp$1 = kcmp; + var vcmp$1 = vcmp; + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + var c = kcmp$1(h1.key, h2.key); + if (c) { + return c; + } else { + var cx = vcmp$1(h1.value, h2.value); + if (cx) { + return cx; + } else { + _e2 = stackAllLeft(h2.right, e2[1]); + _e1 = stackAllLeft(h1.right, e1[1]); + continue ; + + } + } + } else { + return 0; + } + } else { + return 0; + } + }; + } else if (len1 < len2) { + return -1; + } else { + return 1; + } +} + +function eq0(s1, s2, kcmp, vcmp) { + var len1 = length0(s1); + var len2 = length0(s2); + if (len1 === len2) { + var _e1 = stackAllLeft(s1, /* [] */0); + var _e2 = stackAllLeft(s2, /* [] */0); + var kcmp$1 = kcmp; + var vcmp$1 = vcmp; + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + if (kcmp$1(h1.key, h2.key) === 0 && vcmp$1(h1.value, h2.value)) { + _e2 = stackAllLeft(h2.right, e2[1]); + _e1 = stackAllLeft(h1.right, e1[1]); + continue ; + + } else { + return /* false */0; + } + } else { + return /* true */1; + } + } else { + return /* true */1; + } + }; + } else { + return /* false */0; + } +} + +function findOpt0(_n, x, cmp) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + var c = cmp(x, v); + if (c) { + _n = c < 0 ? n.left : n.right; + continue ; + + } else { + return /* Some */[n.value]; + } + } else { + return /* None */0; + } + }; +} + +function findNull0(_n, x, cmp) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + var c = cmp(x, v); + if (c) { + _n = c < 0 ? n.left : n.right; + continue ; + + } else { + return n.value; + } + } else { + return null; + } + }; +} + +function findExn0(_n, x, cmp) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + var c = cmp(x, v); + if (c) { + _n = c < 0 ? n.left : n.right; + continue ; + + } else { + return n.value; + } + } else { + throw new Error("findExn0"); + } + }; +} + +function findWithDefault0(_n, x, def, cmp) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + var c = cmp(x, v); + if (c) { + _n = c < 0 ? n.left : n.right; + continue ; + + } else { + return n.value; + } + } else { + return def; + } + }; +} + +function mem0(_n, x, cmp) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + var c = cmp(x, v); + if (c) { + _n = c < 0 ? n.left : n.right; + continue ; + + } else { + return /* true */1; + } + } else { + return /* false */0; + } + }; +} + +function rotateWithLeftChild(k2) { + var k1 = k2.left; + k2.left = k1.right; + k1.right = k2; + var hlk2 = height(k2.left); + var hrk2 = height(k2.right); + k2.h = ( + hlk2 > hrk2 ? hlk2 : hrk2 + ) + 1 | 0; + var hlk1 = height(k1.left); + var hk2 = k2.h; + k1.h = ( + hlk1 > hk2 ? hlk1 : hk2 + ) + 1 | 0; + return k1; +} + +function rotateWithRightChild(k1) { + var k2 = k1.right; + k1.right = k2.left; + k2.left = k1; + var hlk1 = height(k1.left); + var hrk1 = height(k1.right); + k1.h = ( + hlk1 > hrk1 ? hlk1 : hrk1 + ) + 1 | 0; + var hrk2 = height(k2.right); + var hk1 = k1.h; + k2.h = ( + hrk2 > hk1 ? hrk2 : hk1 + ) + 1 | 0; + return k2; +} + +function doubleWithLeftChild(k3) { + var v = rotateWithRightChild(k3.left); + k3.left = v; + return rotateWithLeftChild(k3); +} + +function doubleWithRightChild(k2) { + var v = rotateWithLeftChild(k2.right); + k2.right = v; + return rotateWithRightChild(k2); +} + +function heightUpdateMutate(t) { + var hlt = height(t.left); + var hrt = height(t.right); + t.h = ( + hlt > hrt ? hlt : hrt + ) + 1 | 0; + return t; +} + +function balMutate(nt) { + var l = nt.left; + var r = nt.right; + var hl = height(l); + var hr = height(r); + if (hl > (2 + hr | 0)) { + var ll = l.left; + var lr = l.right; + if (heightGe(ll, lr)) { + return heightUpdateMutate(rotateWithLeftChild(nt)); + } else { + return heightUpdateMutate(doubleWithLeftChild(nt)); + } + } else if (hr > (2 + hl | 0)) { + var rl = r.left; + var rr = r.right; + if (heightGe(rr, rl)) { + return heightUpdateMutate(rotateWithRightChild(nt)); + } else { + return heightUpdateMutate(doubleWithRightChild(nt)); + } + } else { + nt.h = ( + hl > hr ? hl : hr + ) + 1 | 0; + return nt; + } +} + +function addMutate(cmp, t, x, data) { + if (t !== null) { + var k = t.key; + var c = cmp(x, k); + if (c) { + var l = t.left; + var r = t.right; + if (c < 0) { + var ll = addMutate(cmp, l, x, data); + t.left = ll; + } else { + t.right = addMutate(cmp, r, x, data); + } + return balMutate(t); + } else { + t.key = x; + t.value = data; + return t; + } + } else { + return singleton0(x, data); + } +} + +function ofArray0(cmp, xs) { + var len = xs.length; + if (len) { + var next = Bs_Sort.strictlySortedLength(xs, (function (param, param$1) { + return +(cmp(param[0], param$1[0]) < 0); + })); + var result; + if (next >= 0) { + result = ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = ofSortedArrayRevAux(xs, next - 1 | 0, next); + } + for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ + var match = xs[i]; + result = addMutate(cmp, result, match[0], match[1]); + } + return result; + } else { + return empty0; + } +} + +function removeMinAuxWithRootMutate(nt, n) { + var rn = n.right; + var ln = n.left; + if (ln !== null) { + n.left = removeMinAuxWithRootMutate(nt, ln); + return balMutate(n); + } else { + nt.key = n.key; + return rn; + } +} + exports.copy = copy; exports.create = create; exports.bal = bal; exports.singleton0 = singleton0; +exports.updateKV = updateKV; exports.minKVOpt0 = minKVOpt0; exports.minKVNull0 = minKVNull0; exports.maxKVOpt0 = maxKVOpt0; @@ -594,14 +1059,29 @@ exports.exists0 = exists0; exports.join = join; exports.concat = concat; exports.concatOrJoin = concatOrJoin; -exports.filter0 = filter0; -exports.partition0 = partition0; +exports.filterShared0 = filterShared0; +exports.filterMap0 = filterMap0; +exports.partitionShared0 = partitionShared0; exports.lengthNode = lengthNode; exports.length0 = length0; exports.toList0 = toList0; exports.checkInvariant = checkInvariant; exports.fillArray = fillArray; exports.toArray0 = toArray0; +exports.keysToArray0 = keysToArray0; +exports.valuesToArray0 = valuesToArray0; exports.ofSortedArrayAux = ofSortedArrayAux; +exports.ofSortedArrayRevAux = ofSortedArrayRevAux; exports.ofSortedArrayUnsafe0 = ofSortedArrayUnsafe0; +exports.cmp0 = cmp0; +exports.eq0 = eq0; +exports.findOpt0 = findOpt0; +exports.findNull0 = findNull0; +exports.findWithDefault0 = findWithDefault0; +exports.findExn0 = findExn0; +exports.mem0 = mem0; +exports.ofArray0 = ofArray0; +exports.addMutate = addMutate; +exports.balMutate = balMutate; +exports.removeMinAuxWithRootMutate = removeMinAuxWithRootMutate; /* No side effect */ diff --git a/lib/js/bs_internalMapInt.js b/lib/js/bs_internalMapInt.js new file mode 100644 index 00000000000..20f567651c7 --- /dev/null +++ b/lib/js/bs_internalMapInt.js @@ -0,0 +1,381 @@ +'use strict'; + +var Bs_Sort = require("./bs_Sort.js"); +var Caml_primitive = require("./caml_primitive.js"); +var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); + +function add(t, x, data) { + if (t !== null) { + var k = t.key; + if (x === k) { + return Bs_internalAVLtree.updateKV(t, x, data); + } else { + var v = t.value; + if (x < k) { + return Bs_internalAVLtree.bal(add(t.left, x, data), k, v, t.right); + } else { + return Bs_internalAVLtree.bal(t.left, k, v, add(t.right, x, data)); + } + } + } else { + return Bs_internalAVLtree.singleton0(x, data); + } +} + +function findOpt(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return /* Some */[n.value]; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return /* None */0; + } + }; +} + +function findNull(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return null; + } + }; +} + +function findExn(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + throw new Error("findExn"); + } + }; +} + +function findWithDefault(_n, x, def) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return def; + } + }; +} + +function mem(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return /* true */1; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return /* false */0; + } + }; +} + +function remove(n, x) { + if (n !== null) { + var l = n.left; + var v = n.key; + var r = n.right; + if (x === v) { + if (l !== null) { + if (r !== null) { + var kr = [r.key]; + var vr = [r.value]; + var r$1 = Bs_internalAVLtree.removeMinAuxWithRef(r, kr, vr); + return Bs_internalAVLtree.bal(l, kr[0], vr[0], r$1); + } else { + return l; + } + } else { + return r; + } + } else if (x < v) { + return Bs_internalAVLtree.bal(remove(l, x), v, n.value, r); + } else { + return Bs_internalAVLtree.bal(l, v, n.value, remove(r, x)); + } + } else { + return n; + } +} + +function splitAux(x, n) { + var l = n.left; + var v = n.key; + var d = n.value; + var r = n.right; + if (x === v) { + return /* tuple */[ + l, + /* Some */[d], + r + ]; + } else if (x < v) { + if (l !== null) { + var match = splitAux(x, l); + return /* tuple */[ + match[0], + match[1], + Bs_internalAVLtree.join(match[2], v, d, r) + ]; + } else { + return /* tuple */[ + null, + /* None */0, + n + ]; + } + } else if (r !== null) { + var match$1 = splitAux(x, r); + return /* tuple */[ + Bs_internalAVLtree.join(l, v, d, match$1[0]), + match$1[1], + match$1[2] + ]; + } else { + return /* tuple */[ + n, + /* None */0, + null + ]; + } +} + +function split(x, n) { + if (n !== null) { + return splitAux(x, n); + } else { + return /* tuple */[ + null, + /* None */0, + null + ]; + } +} + +function merge(s1, s2, f) { + var exit = 0; + if (s1 !== null) { + if (s1.h >= ( + s2 !== null ? s2.h : 0 + )) { + var l1 = s1.left; + var v1 = s1.key; + var d1 = s1.value; + var r1 = s1.right; + var match = split(v1, s2); + return Bs_internalAVLtree.concatOrJoin(merge(l1, match[0], f), v1, f(v1, /* Some */[d1], match[1]), merge(r1, match[2], f)); + } else { + exit = 1; + } + } else if (s2 !== null) { + exit = 1; + } else { + return null; + } + if (exit === 1) { + if (s2 !== null) { + var l2 = s2.left; + var v2 = s2.key; + var d2 = s2.value; + var r2 = s2.right; + var match$1 = split(v2, s1); + return Bs_internalAVLtree.concatOrJoin(merge(match$1[0], l2, f), v2, f(v2, match$1[1], /* Some */[d2]), merge(match$1[2], r2, f)); + } else { + return /* assert false */0; + } + } + +} + +function compareAux(_e1, _e2, vcmp) { + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + var c = Caml_primitive.caml_int_compare(h1.key, h2.key); + if (c) { + return c; + } else { + var cx = vcmp(h1.value, h2.value); + if (cx) { + return cx; + } else { + _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); + _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); + continue ; + + } + } + } else { + return 0; + } + } else { + return 0; + } + }; +} + +function cmp(s1, s2, cmp$1) { + var len1 = Bs_internalAVLtree.length0(s1); + var len2 = Bs_internalAVLtree.length0(s2); + if (len1 === len2) { + return compareAux(Bs_internalAVLtree.stackAllLeft(s1, /* [] */0), Bs_internalAVLtree.stackAllLeft(s2, /* [] */0), cmp$1); + } else if (len1 < len2) { + return -1; + } else { + return 1; + } +} + +function eqAux(_e1, _e2, eq) { + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + if (h1.key === h2.key && eq(h1.value, h2.value)) { + _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); + _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); + continue ; + + } else { + return /* false */0; + } + } else { + return /* true */1; + } + } else { + return /* true */1; + } + }; +} + +function eq(s1, s2, eq$1) { + var len1 = Bs_internalAVLtree.length0(s1); + var len2 = Bs_internalAVLtree.length0(s2); + if (len1 === len2) { + return eqAux(Bs_internalAVLtree.stackAllLeft(s1, /* [] */0), Bs_internalAVLtree.stackAllLeft(s2, /* [] */0), eq$1); + } else { + return /* false */0; + } +} + +function addMutate(t, x, data) { + if (t !== null) { + var k = t.key; + if (x === k) { + t.key = x; + t.value = data; + return t; + } else { + var l = t.left; + var r = t.right; + if (x < k) { + var ll = addMutate(l, x, data); + t.left = ll; + } else { + t.right = addMutate(r, x, data); + } + return Bs_internalAVLtree.balMutate(t); + } + } else { + return Bs_internalAVLtree.singleton0(x, data); + } +} + +function ofArray(xs) { + var len = xs.length; + if (len) { + var next = Bs_Sort.strictlySortedLength(xs, (function (param, param$1) { + return +(param[0] < param$1[0]); + })); + var result; + if (next >= 0) { + result = Bs_internalAVLtree.ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = Bs_internalAVLtree.ofSortedArrayRevAux(xs, next - 1 | 0, next); + } + for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ + var match = xs[i]; + result = addMutate(result, match[0], match[1]); + } + return result; + } else { + return Bs_internalAVLtree.empty0; + } +} + +var N = 0; + +var A = 0; + +var S = 0; + +exports.N = N; +exports.A = A; +exports.S = S; +exports.add = add; +exports.findOpt = findOpt; +exports.findNull = findNull; +exports.findExn = findExn; +exports.findWithDefault = findWithDefault; +exports.mem = mem; +exports.remove = remove; +exports.splitAux = splitAux; +exports.split = split; +exports.merge = merge; +exports.compareAux = compareAux; +exports.cmp = cmp; +exports.eqAux = eqAux; +exports.eq = eq; +exports.addMutate = addMutate; +exports.ofArray = ofArray; +/* No side effect */ diff --git a/lib/js/bs_internalMapString.js b/lib/js/bs_internalMapString.js new file mode 100644 index 00000000000..4d289ee42cd --- /dev/null +++ b/lib/js/bs_internalMapString.js @@ -0,0 +1,381 @@ +'use strict'; + +var Bs_Sort = require("./bs_Sort.js"); +var Caml_primitive = require("./caml_primitive.js"); +var Bs_internalAVLtree = require("./bs_internalAVLtree.js"); + +function add(t, x, data) { + if (t !== null) { + var k = t.key; + if (x === k) { + return Bs_internalAVLtree.updateKV(t, x, data); + } else { + var v = t.value; + if (x < k) { + return Bs_internalAVLtree.bal(add(t.left, x, data), k, v, t.right); + } else { + return Bs_internalAVLtree.bal(t.left, k, v, add(t.right, x, data)); + } + } + } else { + return Bs_internalAVLtree.singleton0(x, data); + } +} + +function findOpt(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return /* Some */[n.value]; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return /* None */0; + } + }; +} + +function findNull(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return null; + } + }; +} + +function findExn(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + throw new Error("findExn"); + } + }; +} + +function findWithDefault(_n, x, def) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return n.value; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return def; + } + }; +} + +function mem(_n, x) { + while(true) { + var n = _n; + if (n !== null) { + var v = n.key; + if (x === v) { + return /* true */1; + } else { + _n = x < v ? n.left : n.right; + continue ; + + } + } else { + return /* false */0; + } + }; +} + +function remove(n, x) { + if (n !== null) { + var l = n.left; + var v = n.key; + var r = n.right; + if (x === v) { + if (l !== null) { + if (r !== null) { + var kr = [r.key]; + var vr = [r.value]; + var r$1 = Bs_internalAVLtree.removeMinAuxWithRef(r, kr, vr); + return Bs_internalAVLtree.bal(l, kr[0], vr[0], r$1); + } else { + return l; + } + } else { + return r; + } + } else if (x < v) { + return Bs_internalAVLtree.bal(remove(l, x), v, n.value, r); + } else { + return Bs_internalAVLtree.bal(l, v, n.value, remove(r, x)); + } + } else { + return n; + } +} + +function splitAux(x, n) { + var l = n.left; + var v = n.key; + var d = n.value; + var r = n.right; + if (x === v) { + return /* tuple */[ + l, + /* Some */[d], + r + ]; + } else if (x < v) { + if (l !== null) { + var match = splitAux(x, l); + return /* tuple */[ + match[0], + match[1], + Bs_internalAVLtree.join(match[2], v, d, r) + ]; + } else { + return /* tuple */[ + null, + /* None */0, + n + ]; + } + } else if (r !== null) { + var match$1 = splitAux(x, r); + return /* tuple */[ + Bs_internalAVLtree.join(l, v, d, match$1[0]), + match$1[1], + match$1[2] + ]; + } else { + return /* tuple */[ + n, + /* None */0, + null + ]; + } +} + +function split(x, n) { + if (n !== null) { + return splitAux(x, n); + } else { + return /* tuple */[ + null, + /* None */0, + null + ]; + } +} + +function merge(s1, s2, f) { + var exit = 0; + if (s1 !== null) { + if (s1.h >= ( + s2 !== null ? s2.h : 0 + )) { + var l1 = s1.left; + var v1 = s1.key; + var d1 = s1.value; + var r1 = s1.right; + var match = split(v1, s2); + return Bs_internalAVLtree.concatOrJoin(merge(l1, match[0], f), v1, f(v1, /* Some */[d1], match[1]), merge(r1, match[2], f)); + } else { + exit = 1; + } + } else if (s2 !== null) { + exit = 1; + } else { + return null; + } + if (exit === 1) { + if (s2 !== null) { + var l2 = s2.left; + var v2 = s2.key; + var d2 = s2.value; + var r2 = s2.right; + var match$1 = split(v2, s1); + return Bs_internalAVLtree.concatOrJoin(merge(match$1[0], l2, f), v2, f(v2, match$1[1], /* Some */[d2]), merge(match$1[2], r2, f)); + } else { + return /* assert false */0; + } + } + +} + +function compareAux(_e1, _e2, vcmp) { + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + var c = Caml_primitive.caml_string_compare(h1.key, h2.key); + if (c) { + return c; + } else { + var cx = vcmp(h1.value, h2.value); + if (cx) { + return cx; + } else { + _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); + _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); + continue ; + + } + } + } else { + return 0; + } + } else { + return 0; + } + }; +} + +function cmp(s1, s2, cmp$1) { + var len1 = Bs_internalAVLtree.length0(s1); + var len2 = Bs_internalAVLtree.length0(s2); + if (len1 === len2) { + return compareAux(Bs_internalAVLtree.stackAllLeft(s1, /* [] */0), Bs_internalAVLtree.stackAllLeft(s2, /* [] */0), cmp$1); + } else if (len1 < len2) { + return -1; + } else { + return 1; + } +} + +function eqAux(_e1, _e2, eq) { + while(true) { + var e2 = _e2; + var e1 = _e1; + if (e1) { + if (e2) { + var h2 = e2[0]; + var h1 = e1[0]; + if (h1.key === h2.key && eq(h1.value, h2.value)) { + _e2 = Bs_internalAVLtree.stackAllLeft(h2.right, e2[1]); + _e1 = Bs_internalAVLtree.stackAllLeft(h1.right, e1[1]); + continue ; + + } else { + return /* false */0; + } + } else { + return /* true */1; + } + } else { + return /* true */1; + } + }; +} + +function eq(s1, s2, eq$1) { + var len1 = Bs_internalAVLtree.length0(s1); + var len2 = Bs_internalAVLtree.length0(s2); + if (len1 === len2) { + return eqAux(Bs_internalAVLtree.stackAllLeft(s1, /* [] */0), Bs_internalAVLtree.stackAllLeft(s2, /* [] */0), eq$1); + } else { + return /* false */0; + } +} + +function addMutate(t, x, data) { + if (t !== null) { + var k = t.key; + if (x === k) { + t.key = x; + t.value = data; + return t; + } else { + var l = t.left; + var r = t.right; + if (x < k) { + var ll = addMutate(l, x, data); + t.left = ll; + } else { + t.right = addMutate(r, x, data); + } + return Bs_internalAVLtree.balMutate(t); + } + } else { + return Bs_internalAVLtree.singleton0(x, data); + } +} + +function ofArray(xs) { + var len = xs.length; + if (len) { + var next = Bs_Sort.strictlySortedLength(xs, (function (param, param$1) { + return +(param[0] < param$1[0]); + })); + var result; + if (next >= 0) { + result = Bs_internalAVLtree.ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = Bs_internalAVLtree.ofSortedArrayRevAux(xs, next - 1 | 0, next); + } + for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ + var match = xs[i]; + result = addMutate(result, match[0], match[1]); + } + return result; + } else { + return Bs_internalAVLtree.empty0; + } +} + +var N = 0; + +var A = 0; + +var S = 0; + +exports.N = N; +exports.A = A; +exports.S = S; +exports.add = add; +exports.findOpt = findOpt; +exports.findNull = findNull; +exports.findExn = findExn; +exports.findWithDefault = findWithDefault; +exports.mem = mem; +exports.remove = remove; +exports.splitAux = splitAux; +exports.split = split; +exports.merge = merge; +exports.compareAux = compareAux; +exports.cmp = cmp; +exports.eqAux = eqAux; +exports.eq = eq; +exports.addMutate = addMutate; +exports.ofArray = ofArray; +/* No side effect */ diff --git a/lib/js/bs_internalSetInt.js b/lib/js/bs_internalSetInt.js index 862e2e2b519..5e00dddbd16 100644 --- a/lib/js/bs_internalSetInt.js +++ b/lib/js/bs_internalSetInt.js @@ -1,36 +1,8 @@ 'use strict'; +var Bs_SortInt = require("./bs_SortInt.js"); var Bs_internalAVLset = require("./bs_internalAVLset.js"); -function add(t, x) { - if (t !== null) { - var v = t.key; - if (x === v) { - return t; - } else { - var l = t.left; - var r = t.right; - if (x < v) { - var ll = add(l, x); - if (ll === l) { - return t; - } else { - return Bs_internalAVLset.bal(ll, v, r); - } - } else { - var rr = add(r, x); - if (rr === r) { - return t; - } else { - return Bs_internalAVLset.bal(l, v, add(r, x)); - } - } - } - } else { - return Bs_internalAVLset.singleton0(x); - } -} - function mem(_t, x) { while(true) { var t = _t; @@ -49,43 +21,6 @@ function mem(_t, x) { }; } -function remove(t, x) { - if (t !== null) { - var l = t.left; - var v = t.key; - var r = t.right; - if (x === v) { - if (l !== null) { - if (r !== null) { - var v$1 = [r.key]; - var r$1 = Bs_internalAVLset.removeMinAuxWithRef(r, v$1); - return Bs_internalAVLset.bal(l, v$1[0], r$1); - } else { - return l; - } - } else { - return r; - } - } else if (x < v) { - var ll = remove(l, x); - if (ll === l) { - return t; - } else { - return Bs_internalAVLset.bal(ll, v, r); - } - } else { - var rr = remove(r, x); - if (rr === r) { - return t; - } else { - return Bs_internalAVLset.bal(l, v, rr); - } - } - } else { - return t; - } -} - function compareAux(_e1, _e2) { while(true) { var e2 = _e2; @@ -232,31 +167,17 @@ function addMutate(t, x) { } } -function sortedLengthAux(xs, _prec, _acc, len) { - while(true) { - var acc = _acc; - var prec = _prec; - if (acc >= len) { - return acc; - } else { - var v = xs[acc]; - if (v > prec) { - _acc = acc + 1 | 0; - _prec = v; - continue ; - - } else { - return acc; - } - } - }; -} - function ofArray(xs) { var len = xs.length; if (len) { - var next = sortedLengthAux(xs, xs[0], 1, len); - var result = Bs_internalAVLset.ofSortedArrayAux(xs, 0, next); + var next = Bs_SortInt.strictlySortedLength(xs); + var result; + if (next >= 0) { + result = Bs_internalAVLset.ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = Bs_internalAVLset.ofSortedArrayRevAux(xs, next - 1 | 0, next); + } for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ result = addMutate(result, xs[i]); } @@ -266,15 +187,16 @@ function ofArray(xs) { } } +var S = 0; + var N = 0; var A = 0; +exports.S = S; exports.N = N; exports.A = A; -exports.add = add; exports.mem = mem; -exports.remove = remove; exports.compareAux = compareAux; exports.cmp = cmp; exports.eq = eq; @@ -282,6 +204,5 @@ exports.subset = subset; exports.findOpt = findOpt; exports.findNull = findNull; exports.addMutate = addMutate; -exports.sortedLengthAux = sortedLengthAux; exports.ofArray = ofArray; /* No side effect */ diff --git a/lib/js/bs_internalSetString.js b/lib/js/bs_internalSetString.js index 862e2e2b519..2715c5bfde9 100644 --- a/lib/js/bs_internalSetString.js +++ b/lib/js/bs_internalSetString.js @@ -1,36 +1,8 @@ 'use strict'; +var Bs_SortString = require("./bs_SortString.js"); var Bs_internalAVLset = require("./bs_internalAVLset.js"); -function add(t, x) { - if (t !== null) { - var v = t.key; - if (x === v) { - return t; - } else { - var l = t.left; - var r = t.right; - if (x < v) { - var ll = add(l, x); - if (ll === l) { - return t; - } else { - return Bs_internalAVLset.bal(ll, v, r); - } - } else { - var rr = add(r, x); - if (rr === r) { - return t; - } else { - return Bs_internalAVLset.bal(l, v, add(r, x)); - } - } - } - } else { - return Bs_internalAVLset.singleton0(x); - } -} - function mem(_t, x) { while(true) { var t = _t; @@ -49,43 +21,6 @@ function mem(_t, x) { }; } -function remove(t, x) { - if (t !== null) { - var l = t.left; - var v = t.key; - var r = t.right; - if (x === v) { - if (l !== null) { - if (r !== null) { - var v$1 = [r.key]; - var r$1 = Bs_internalAVLset.removeMinAuxWithRef(r, v$1); - return Bs_internalAVLset.bal(l, v$1[0], r$1); - } else { - return l; - } - } else { - return r; - } - } else if (x < v) { - var ll = remove(l, x); - if (ll === l) { - return t; - } else { - return Bs_internalAVLset.bal(ll, v, r); - } - } else { - var rr = remove(r, x); - if (rr === r) { - return t; - } else { - return Bs_internalAVLset.bal(l, v, rr); - } - } - } else { - return t; - } -} - function compareAux(_e1, _e2) { while(true) { var e2 = _e2; @@ -232,31 +167,17 @@ function addMutate(t, x) { } } -function sortedLengthAux(xs, _prec, _acc, len) { - while(true) { - var acc = _acc; - var prec = _prec; - if (acc >= len) { - return acc; - } else { - var v = xs[acc]; - if (v > prec) { - _acc = acc + 1 | 0; - _prec = v; - continue ; - - } else { - return acc; - } - } - }; -} - function ofArray(xs) { var len = xs.length; if (len) { - var next = sortedLengthAux(xs, xs[0], 1, len); - var result = Bs_internalAVLset.ofSortedArrayAux(xs, 0, next); + var next = Bs_SortString.strictlySortedLength(xs); + var result; + if (next >= 0) { + result = Bs_internalAVLset.ofSortedArrayAux(xs, 0, next); + } else { + next = -next | 0; + result = Bs_internalAVLset.ofSortedArrayRevAux(xs, next - 1 | 0, next); + } for(var i = next ,i_finish = len - 1 | 0; i <= i_finish; ++i){ result = addMutate(result, xs[i]); } @@ -266,15 +187,16 @@ function ofArray(xs) { } } +var S = 0; + var N = 0; var A = 0; +exports.S = S; exports.N = N; exports.A = A; -exports.add = add; exports.mem = mem; -exports.remove = remove; exports.compareAux = compareAux; exports.cmp = cmp; exports.eq = eq; @@ -282,6 +204,5 @@ exports.subset = subset; exports.findOpt = findOpt; exports.findNull = findNull; exports.addMutate = addMutate; -exports.sortedLengthAux = sortedLengthAux; exports.ofArray = ofArray; /* No side effect */ diff --git a/lib/js/camlinternalOO.js b/lib/js/camlinternalOO.js index 85c8a930c10..88e63b2c48c 100644 --- a/lib/js/camlinternalOO.js +++ b/lib/js/camlinternalOO.js @@ -106,13 +106,13 @@ function new_method(table) { } function get_method_label(table, name) { - var match = Bs_MapString.findOpt(name, table[/* methods_by_name */2]); - if (match) { - return match[0]; + var match = Bs_MapString.findNull(table[/* methods_by_name */2], name); + if (match !== null) { + return match; } else { var label = new_method(table); - table[/* methods_by_name */2] = Bs_MapString.add(table[/* methods_by_name */2], name, label); - table[/* methods_by_label */3] = Bs_MapInt.add(table[/* methods_by_label */3], label, /* true */1); + table[/* methods_by_name */2] = Bs_MapString.update(table[/* methods_by_name */2], name, label); + table[/* methods_by_label */3] = Bs_MapInt.update(table[/* methods_by_label */3], label, /* true */1); return label; } } @@ -125,7 +125,7 @@ function get_method_labels(table, names) { function set_method(table, label, element) { method_count[0] = method_count[0] + 1 | 0; - if (Bs_MapInt.findAssert(label, table[/* methods_by_label */3])) { + if (Bs_MapInt.findExn(table[/* methods_by_label */3], label)) { var array = table; var label$1 = label; var element$1 = element; @@ -187,7 +187,7 @@ function narrow(table, vars, virt_meths, concr_meths) { ]; table[/* vars */6] = Bs_MapString.fold(table[/* vars */6], Bs_MapString.empty, (function (tvars, lab, info) { if (List.mem(lab, vars$1)) { - return Bs_MapString.add(tvars, lab, info); + return Bs_MapString.update(tvars, lab, info); } else { return tvars; } @@ -195,13 +195,13 @@ function narrow(table, vars, virt_meths, concr_meths) { var by_name = [Bs_MapString.empty]; var by_label = [Bs_MapInt.empty]; List.iter2((function (met, label) { - by_name[0] = Bs_MapString.add(by_name[0], met, label); - by_label[0] = Bs_MapInt.add(by_label[0], label, Bs_MapInt.findWithDefault(table[/* methods_by_label */3], label, /* true */1)); + by_name[0] = Bs_MapString.update(by_name[0], met, label); + by_label[0] = Bs_MapInt.update(by_label[0], label, Bs_MapInt.findWithDefault(table[/* methods_by_label */3], label, /* true */1)); return /* () */0; }), concr_meths$1, concr_meth_labs); List.iter2((function (met, label) { - by_name[0] = Bs_MapString.add(by_name[0], met, label); - by_label[0] = Bs_MapInt.add(by_label[0], label, /* false */0); + by_name[0] = Bs_MapString.update(by_name[0], met, label); + by_label[0] = Bs_MapInt.update(by_label[0], label, /* false */0); return /* () */0; }), virt_meths$1, virt_meth_labs); table[/* methods_by_name */2] = by_name[0]; @@ -224,7 +224,7 @@ function widen(table) { var virt_meths = match[4]; table[/* previous_states */4] = List.tl(table[/* previous_states */4]); table[/* vars */6] = List.fold_left((function (s, v) { - return Bs_MapString.add(s, v, Bs_MapString.findAssert(v, table[/* vars */6])); + return Bs_MapString.update(s, v, Bs_MapString.findExn(table[/* vars */6], v)); }), match[3], match[5]); table[/* methods_by_name */2] = match[0]; table[/* methods_by_label */3] = match[1]; @@ -248,13 +248,13 @@ function new_slot(table) { } function new_variable(table, name) { - var match = Bs_MapString.findOpt(name, table[/* vars */6]); - if (match) { - return match[0]; + var match = Bs_MapString.findNull(table[/* vars */6], name); + if (match !== null) { + return match; } else { var index = new_slot(table); if (name !== "") { - table[/* vars */6] = Bs_MapString.add(table[/* vars */6], name, index); + table[/* vars */6] = Bs_MapString.update(table[/* vars */6], name, index); } return index; } @@ -283,12 +283,12 @@ function new_methods_variables(table, meths, vals) { } function get_variable(table, name) { - return Bs_MapString.findAssert(name, table[/* vars */6]); + return Bs_MapString.findExn(table[/* vars */6], name); } function get_variables(table, names) { return $$Array.map((function (param) { - return Bs_MapString.findAssert(param, table[/* vars */6]); + return Bs_MapString.findExn(table[/* vars */6], param); }), names); } @@ -306,8 +306,8 @@ function create_table(public_methods) { var table = new_table(tags); $$Array.iteri((function (i, met) { var lab = (i << 1) + 2 | 0; - table[/* methods_by_name */2] = Bs_MapString.add(table[/* methods_by_name */2], met, lab); - table[/* methods_by_label */3] = Bs_MapInt.add(table[/* methods_by_label */3], lab, /* true */1); + table[/* methods_by_name */2] = Bs_MapString.update(table[/* methods_by_name */2], met, lab); + table[/* methods_by_label */3] = Bs_MapInt.update(table[/* methods_by_label */3], lab, /* true */1); return /* () */0; }), public_methods); return table; @@ -331,7 +331,7 @@ function inherits(cla, vals, virt_meths, concr_meths, param, top) { /* array */[init], /* :: */[ $$Array.map((function (param) { - return Bs_MapString.findAssert(param, cla[/* vars */6]); + return Bs_MapString.findExn(cla[/* vars */6], param); }), to_array(vals)), /* :: */[ $$Array.map((function (nm) { diff --git a/lib/js/js_null.js b/lib/js/js_null.js index 24a38bf36ab..be771ec7384 100644 --- a/lib/js/js_null.js +++ b/lib/js/js_null.js @@ -1,11 +1,11 @@ 'use strict'; -function castExn(f) { +function getExn(f) { if (f !== null) { return f; } else { - throw new Error("Js.Null.castExn"); + throw new Error("Js.Null.getExn"); } } @@ -35,7 +35,7 @@ function fromOption(x) { var from_opt = fromOption; -exports.castExn = castExn; +exports.getExn = getExn; exports.bind = bind; exports.iter = iter; exports.fromOption = fromOption; diff --git a/lib/whole_compiler.ml b/lib/whole_compiler.ml index dc210b626ab..23896681170 100644 --- a/lib/whole_compiler.ml +++ b/lib/whole_compiler.ml @@ -100170,7 +100170,7 @@ let rec eliminate_ref id (lam : Lam.t) = | Lprim {primitive = Pfield (0,_); args = [Lvar v]} when Ident.same v id -> Lam.var id | Lfunction{ function_kind; params; body} as lam -> - if Ident_set.mem id (Lam.free_variables lam) + if Ident_set.mem id (Lam.free_variables lam) (*TODO: optmization: no need construct*) then raise_notrace Real_reference else lam (* In Javascript backend, its okay, we can reify it later