diff --git a/src/core/CCArray.ml b/src/core/CCArray.ml index 37020788..2b65123a 100644 --- a/src/core/CCArray.ml +++ b/src/core/CCArray.ml @@ -709,3 +709,20 @@ module Infix = struct let (--) = (--) let (--^) = (--^) end + + +(* test consistency of interfaces *) +(*$inject + module FA = CCShims_.Stdlib.Array.Floatarray + module type L = module type of CCArray with module Floatarray := FA + module type LL = module type of CCArrayLabels with module Floatarray := FA +*) + +(*$R + ignore (module CCArrayLabels : L) +*) + +(*$R + ignore (module CCArray : LL) +*) + diff --git a/src/core/CCArray_slice.ml b/src/core/CCArray_slice.ml index 728e3230..a9db0cab 100644 --- a/src/core/CCArray_slice.ml +++ b/src/core/CCArray_slice.ml @@ -418,3 +418,19 @@ let to_seq a k = iter k a let to_gen a = _to_gen a.arr a.i a.j let to_klist a = _to_klist a.arr a.i a.j + + +(* test consistency of interfaces *) +(*$inject + module type L = module type of CCArray_slice + module type LL = module type of CCArray_sliceLabels +*) + +(*$R + ignore (module CCArray_sliceLabels : L) +*) + +(*$R + ignore (module CCArray_slice : LL) +*) + diff --git a/src/core/CCEqualLabels.mli b/src/core/CCEqualLabels.mli index 52b91f9e..61ce6a69 100644 --- a/src/core/CCEqualLabels.mli +++ b/src/core/CCEqualLabels.mli @@ -42,3 +42,18 @@ module Infix : sig end include module type of Infix + +(* test consistency of interfaces *) +(*$inject + module type L = module type of CCEqual + module type LL = module type of CCEqualLabels +*) + +(*$R + ignore (module CCEqualLabels : L) +*) + +(*$R + ignore (module CCEqual : LL) +*) + diff --git a/src/core/CCFormat.ml b/src/core/CCFormat.ml index 06f5dbbc..e1ff197a 100644 --- a/src/core/CCFormat.ml +++ b/src/core/CCFormat.ml @@ -418,8 +418,8 @@ module Dump = struct let triple p1 p2 p3 = within "(" ")" (hovbox (triple p1 p2 p3)) let quad p1 p2 p3 p4 = within "(" ")" (hovbox (quad p1 p2 p3 p4)) let result' pok perror out = function - | Result.Ok x -> Format.fprintf out "(@[Ok %a@])" pok x - | Result.Error e -> Format.fprintf out "(@[Error %a@])" perror e + | Ok x -> Format.fprintf out "(@[Ok %a@])" pok x + | Error e -> Format.fprintf out "(@[Error %a@])" perror e let result pok = result' pok string let to_string = to_string end @@ -429,5 +429,5 @@ end "Some 1" (to_string Dump.(option int) (Some 1)) "[None;Some \"a b\"]" (to_string Dump.(list (option string)) [None; Some "a b"]) "[(Ok \"a b c\");(Error \"nope\")]" \ - (to_string Dump.(list (result string)) [Result.Ok "a b c"; Result.Error "nope"]) + (to_string Dump.(list (result string)) [Ok "a b c"; Error "nope"]) *) diff --git a/src/core/CCFormat.mli b/src/core/CCFormat.mli index 506b6aa7..3fdb0b27 100644 --- a/src/core/CCFormat.mli +++ b/src/core/CCFormat.mli @@ -329,8 +329,8 @@ module Dump : sig val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t - val result : 'a t -> ('a, string) Result.result t - val result' : 'a t -> 'e t -> ('a, 'e) Result.result t + val result : 'a t -> ('a, string) result t + val result' : 'a t -> 'e t -> ('a, 'e) result t val to_string : 'a t -> 'a -> string (** Alias to {!CCFormat.to_string}. *) end diff --git a/src/core/CCIO.ml b/src/core/CCIO.ml index 01f446d5..1f363465 100644 --- a/src/core/CCIO.ml +++ b/src/core/CCIO.ml @@ -3,7 +3,7 @@ (** {1 IO Utils} *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a gen = unit -> 'a option let gen_empty () = None @@ -256,28 +256,28 @@ module File = struct let remove_exn f = Sys.remove f let remove f = - try Result.Ok (Sys.remove f) + try Ok (Sys.remove f) with exn -> - Result.Error (Printexc.to_string exn) + Error (Printexc.to_string exn) let read_exn f = with_in f (read_all_ ~op:Ret_string ~size:4096) let read f = - try Result.Ok (read_exn f) with e -> Result.Error (Printexc.to_string e) + try Ok (read_exn f) with e -> Error (Printexc.to_string e) let append_exn f x = with_out ~flags:[Open_append; Open_creat; Open_text] f (fun oc -> output_string oc x; flush oc) let append f x = - try Result.Ok (append_exn f x) with e -> Result.Error (Printexc.to_string e) + try Ok (append_exn f x) with e -> Error (Printexc.to_string e) let write_exn f x = with_out f (fun oc -> output_string oc x; flush oc) let write f x = - try Result.Ok (write_exn f x) with e -> Result.Error (Printexc.to_string e) + try Ok (write_exn f x) with e -> Error (Printexc.to_string e) let remove_noerr f = try Sys.remove f with _ -> () diff --git a/src/core/CCIO.mli b/src/core/CCIO.mli index b4d39b5d..1b39187d 100644 --- a/src/core/CCIO.mli +++ b/src/core/CCIO.mli @@ -52,7 +52,7 @@ *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a gen = unit -> 'a option (** See [Gen] in the {{: https://github.com/c-cube/gen} gen library}. *) diff --git a/src/core/CCList.ml b/src/core/CCList.ml index 96548f8e..8288e2af 100644 --- a/src/core/CCList.ml +++ b/src/core/CCList.ml @@ -1027,8 +1027,8 @@ let keep_some l = filter_map (fun x->x) l let keep_ok l = filter_map (function - | Result.Ok x -> Some x - | Result.Error _ -> None) + | Ok x -> Some x + | Error _ -> None) l let all_some l = @@ -1044,14 +1044,14 @@ let all_some l = let all_ok l = let err = ref None in try - Result.Ok + Ok (map - (function Result.Ok x -> x | Result.Error e -> err := Some e; raise Exit) + (function Ok x -> x | Error e -> err := Some e; raise Exit) l) with Exit -> begin match !err with | None -> assert false - | Some e -> Result.Error e + | Some e -> Error e end let group_by (type k) ?(hash=Hashtbl.hash) ?(eq=Stdlib.(=)) l = @@ -1158,10 +1158,6 @@ let group_join_by (type a) ?(eq=Stdlib.(=)) ?(hash=Hashtbl.hash) f c1 c2 = |> sort Stdlib.compare) *) -(*$inject - open Result -*) - (*$= (Ok []) (all_ok []) (Ok [1;2;3]) (all_ok [Ok 1; Ok 2; Ok 3]) @@ -1746,3 +1742,18 @@ let pp ?(start="") ?(stop="") ?(sep=", ") pp_item fmt l = [1;2;3]) *) + +(* test consistency of interfaces *) +(*$inject + module type L = module type of CCList + module type LL = module type of CCListLabels +*) + +(*$R + ignore (module CCListLabels : L) +*) + +(*$R + ignore (module CCList : LL) +*) + diff --git a/src/core/CCList.mli b/src/core/CCList.mli index 533c3ef5..b93daa6d 100644 --- a/src/core/CCList.mli +++ b/src/core/CCList.mli @@ -394,7 +394,7 @@ val keep_some : 'a option t -> 'a t @since 1.3, but only @since 2.2 with labels *) -val keep_ok : ('a, _) Result.result t -> 'a t +val keep_ok : ('a, _) result t -> 'a t (** [keep_ok l] retains only elements of the form [Ok x]. @since 1.3, but only @since 2.2 with labels *) @@ -405,7 +405,7 @@ val all_some : 'a option t -> 'a t option @since 1.3, but only @since 2.2 with labels *) -val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result +val all_ok : ('a, 'err) result t -> ('a t, 'err) result (** [all_ok l] returns [Ok l'] if all elements of [l] are of the form [Ok x], or [Error e] otherwise (with the first error met). @since 1.3, but only diff --git a/src/core/CCListLabels.mli b/src/core/CCListLabels.mli index 310ea91a..de89d3a2 100644 --- a/src/core/CCListLabels.mli +++ b/src/core/CCListLabels.mli @@ -392,7 +392,7 @@ val keep_some : 'a option t -> 'a t @since 1.3, but only @since 2.2 with labels *) -val keep_ok : ('a, _) Result.result t -> 'a t +val keep_ok : ('a, _) result t -> 'a t (** [keep_ok l] retains only elements of the form [Ok x]. @since 1.3, but only @since 2.2 with labels *) @@ -403,7 +403,7 @@ val all_some : 'a option t -> 'a t option @since 1.3, but only @since 2.2 with labels *) -val all_ok : ('a, 'err) Result.result t -> ('a t, 'err) Result.result +val all_ok : ('a, 'err) result t -> ('a t, 'err) result (** [all_ok l] returns [Ok l'] if all elements of [l] are of the form [Ok x], or [Error e] otherwise (with the first error met). @since 1.3, but only diff --git a/src/core/CCOpt.ml b/src/core/CCOpt.ml index 45bba9b9..ed379270 100644 --- a/src/core/CCOpt.ml +++ b/src/core/CCOpt.ml @@ -150,16 +150,16 @@ let of_list = function | [] -> None let to_result err = function - | None -> Result.Error err - | Some x -> Result.Ok x + | None -> Error err + | Some x -> Ok x let to_result_lazy err_fn = function - | None -> Result.Error (err_fn ()) - | Some x -> Result.Ok x + | None -> Error (err_fn ()) + | Some x -> Ok x let of_result = function - | Result.Error _ -> None - | Result.Ok x -> Some x + | Error _ -> None + | Ok x -> Some x module Infix = struct let (>|=) = (>|=) diff --git a/src/core/CCOpt.mli b/src/core/CCOpt.mli index 5c8bb367..de0f1b93 100644 --- a/src/core/CCOpt.mli +++ b/src/core/CCOpt.mli @@ -163,13 +163,13 @@ val to_list : 'a t -> 'a list val of_list : 'a list -> 'a t (** Head of list, or [None]. *) -val to_result : 'e -> 'a t -> ('a, 'e) Result.result +val to_result : 'e -> 'a t -> ('a, 'e) result (** @since 1.2 *) -val to_result_lazy : (unit -> 'e) -> 'a t -> ('a, 'e) Result.result +val to_result_lazy : (unit -> 'e) -> 'a t -> ('a, 'e) result (** @since 1.2 *) -val of_result : ('a, _) Result.result -> 'a t +val of_result : ('a, _) result -> 'a t (** @since 1.2 *) type 'a sequence = ('a -> unit) -> unit diff --git a/src/core/CCParse.ml b/src/core/CCParse.ml index 0ac1a251..a18b425e 100644 --- a/src/core/CCParse.ml +++ b/src/core/CCParse.ml @@ -100,7 +100,7 @@ open CCShims_ () *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type line_num = int type col_num = int @@ -443,10 +443,10 @@ let parse_exn p st = | None -> assert false | Some x -> x -let exn_to_err e =Result.Error (Printexc.to_string e) +let exn_to_err e = Error (Printexc.to_string e) let parse p st = - try Result.Ok (parse_exn p st) + try Ok (parse_exn p st) with e -> exn_to_err e let parse_string_exn p s = parse_exn p (state_of_string s) @@ -479,7 +479,7 @@ let parse_file_exn p file = raise e let parse_file p file = - try Result.Ok (parse_file_exn p file) + try Ok (parse_file_exn p file) with e -> exn_to_err e module Infix = struct diff --git a/src/core/CCParse.mli b/src/core/CCParse.mli index 066a4ead..1aa787ee 100644 --- a/src/core/CCParse.mli +++ b/src/core/CCParse.mli @@ -48,7 +48,7 @@ *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type line_num = int type col_num = int diff --git a/src/core/CCResult.ml b/src/core/CCResult.ml index 9fd490b2..040ea008 100644 --- a/src/core/CCResult.ml +++ b/src/core/CCResult.ml @@ -9,9 +9,7 @@ type 'a printer = Format.formatter -> 'a -> unit (** {2 Basics} *) -include Result - -type (+'good, +'bad) t = ('good, 'bad) Result.result = +type (+'good, +'bad) t = ('good, 'bad) result = | Ok of 'good | Error of 'bad diff --git a/src/core/CCResult.mli b/src/core/CCResult.mli index acb4edd2..ddf622f7 100644 --- a/src/core/CCResult.mli +++ b/src/core/CCResult.mli @@ -13,10 +13,7 @@ type 'a printer = Format.formatter -> 'a -> unit (** {2 Basics} *) -include module type of struct include Result end -(** @since 1.5 *) - -type (+'good, +'bad) t = ('good, 'bad) Result.result = +type (+'good, +'bad) t = ('good, 'bad) result = | Ok of 'good | Error of 'bad diff --git a/src/core/CCString.ml b/src/core/CCString.ml index 74442efd..f947184c 100644 --- a/src/core/CCString.ml +++ b/src/core/CCString.ml @@ -1162,3 +1162,18 @@ module Sub = struct let pp fmt s = Format.fprintf fmt "\"%s\"" (copy s) end + +(* test consistency of interfaces *) +(*$inject + module type L = module type of CCString + module type LL = module type of CCStringLabels +*) + +(*$R + ignore (module CCStringLabels : L) +*) + +(*$R + ignore (module CCString : LL) +*) + diff --git a/src/core/dune b/src/core/dune index 1e6479cc..62ee34f0 100644 --- a/src/core/dune +++ b/src/core/dune @@ -1,42 +1,3 @@ -(alias - (name unlabel) - (deps - (:mli CCArrayLabels.mli) - ../unlabel.exe) - (action - (run ../unlabel.exe %{mli} CCArray.mli))) - -(alias - (name unlabel) - (deps - (:mli CCArray_sliceLabels.mli) - ../unlabel.exe) - (action - (run ../unlabel.exe %{mli} CCArray_slice.mli))) - -(alias - (name unlabel) - (deps - (:mli CCEqualLabels.mli) - ../unlabel.exe) - (action - (run ../unlabel.exe %{mli} CCEqual.mli))) - -(alias - (name unlabel) - (deps - (:mli CCListLabels.mli) - ../unlabel.exe) - (action - (run ../unlabel.exe %{mli} CCList.mli))) - -(alias - (name unlabel) - (deps - (:mli CCStringLabels.mli) - ../unlabel.exe) - (action - (run ../unlabel.exe %{mli} CCString.mli))) (executable (name mkshims) diff --git a/src/core/mkshims.ml b/src/core/mkshims.ml index 2a5e19cd..df1461ae 100644 --- a/src/core/mkshims.ml +++ b/src/core/mkshims.ml @@ -80,6 +80,24 @@ let shims_array_pre_408 = " " let shims_array_post_408 = "include Array" +let shims_let_op_pre_408 = + "module Make_let_applicative(X:sig end) = struct end + module Make_let_functor(X:sig end) = struct end +" +let shims_let_op_post_408 = + "module Make_let_applicative(X:sig + type 'a t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + val (<*>) : ('a -> 'b) t -> 'a t -> 'b t + end) = struct + end + module Make_let_functor(X:sig + type 'a t + val (>>=) : 'a t -> ('a -> 'b t) -> 'b t + end) = struct + end +" + let () = C.main ~name:"mkshims" (fun c -> let version = C.ocaml_config_var_exn c "version" in diff --git a/src/dune b/src/dune index ff298374..2c7956a1 100644 --- a/src/dune +++ b/src/dune @@ -3,11 +3,6 @@ (modules mkflags) (libraries dune.configurator)) -(executable - (name unlabel) - (modules unlabel) - (libraries compiler-libs.common)) - (env (_ (flags :standard -warn-error -3))) diff --git a/src/iter/dune b/src/iter/dune index 49633032..6a8aa926 100644 --- a/src/iter/dune +++ b/src/iter/dune @@ -4,6 +4,4 @@ (public_name containers.iter) (wrapped false) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) - (ocamlopt_flags :standard (:include ../flambda.flags)) - (libraries dune) - ) + (ocamlopt_flags :standard (:include ../flambda.flags))) diff --git a/src/sexp/CCSexp.ml b/src/sexp/CCSexp.ml index e57695d9..201ab78b 100644 --- a/src/sexp/CCSexp.ml +++ b/src/sexp/CCSexp.ml @@ -4,7 +4,7 @@ open CCShims_ -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option @@ -134,7 +134,7 @@ module Make(Sexp : SEXP) = struct x with e -> close_in ic; - Result.Error (Printexc.to_string e) + Error (Printexc.to_string e) (** A parser of ['a] can return [Yield x] when it parsed a value, or [Fail e] when a parse error was encountered, or @@ -234,9 +234,9 @@ module Make(Sexp : SEXP) = struct let to_list (d:t) : _ or_error = let rec iter acc = match next d with - | End -> Result.Ok (List.rev acc) + | End -> Ok (List.rev acc) | Yield x -> iter (x::acc) - | Fail e -> Result.Error e + | Fail e -> Error e in try iter [] with e -> Error (Printexc.to_string e) @@ -244,9 +244,9 @@ module Make(Sexp : SEXP) = struct let dec_next_ (d:Decoder.t) : _ or_error = match Decoder.next d with - | End -> Result.Error "unexpected end of file" - | Yield x -> Result.Ok x - | Fail s -> Result.Error s + | End -> Error "unexpected end of file" + | Yield x -> Ok x + | Fail s -> Error s let parse_string s : t or_error = let buf = Lexing.from_string s in @@ -284,8 +284,8 @@ module Make(Sexp : SEXP) = struct let d = Decoder.of_lexbuf buf in fun () -> match Decoder.next d with | End -> None - | Fail e -> Some (Result.Error e) - | Yield x -> Some (Result.Ok x) + | Fail e -> Some (Error e) + | Yield x -> Some (Ok x) let parse_file filename = _with_in filename (parse_chan_ ~file:filename) @@ -341,20 +341,20 @@ include (Make(struct CCResult.to_opt (parse_string "\"\123\bcoucou\"") <> None *) -(*$= & ~printer:(function Result.Ok x -> to_string x | Result.Error e -> "error " ^ e) - (parse_string "(a b)") (Result.Ok (`List [`Atom "a"; `Atom "b"])) - (parse_string "(a\n ;coucou\n b)") (Result.Ok (`List [`Atom "a"; `Atom "b"])) - (parse_string "(a #; (foo bar\n (1 2 3)) b)") (Result.Ok (`List [`Atom "a"; `Atom "b"])) - (parse_string "#; (a b) (c d)") (Result.Ok (`List [`Atom "c"; `Atom "d"])) - (parse_string "#; (a b) 1") (Result.Ok (`Atom "1")) +(*$= & ~printer:(function Ok x -> to_string x | Error e -> "error " ^ e) + (parse_string "(a b)") (Ok (`List [`Atom "a"; `Atom "b"])) + (parse_string "(a\n ;coucou\n b)") (Ok (`List [`Atom "a"; `Atom "b"])) + (parse_string "(a #; (foo bar\n (1 2 3)) b)") (Ok (`List [`Atom "a"; `Atom "b"])) + (parse_string "#; (a b) (c d)") (Ok (`List [`Atom "c"; `Atom "d"])) + (parse_string "#; (a b) 1") (Ok (`Atom "1")) *) -(*$= & ~printer:(function Result.Ok x -> String.concat ";" @@ List.map to_string x | Result.Error e -> "error " ^ e) - (parse_string_list "(a b)(c)") (Result.Ok [`List [`Atom "a"; `Atom "b"]; `List [`Atom "c"]]) - (parse_string_list " ") (Result.Ok []) - (parse_string_list "(a\n ;coucou\n b)") (Result.Ok [`List [`Atom "a"; `Atom "b"]]) - (parse_string_list "#; (a b) (c d) e ") (Result.Ok [`List [`Atom "c"; `Atom "d"]; `Atom "e"]) - (parse_string_list "#; (a b) 1") (Result.Ok [`Atom "1"]) +(*$= & ~printer:(function Ok x -> String.concat ";" @@ List.map to_string x | Error e -> "error " ^ e) + (parse_string_list "(a b)(c)") (Ok [`List [`Atom "a"; `Atom "b"]; `List [`Atom "c"]]) + (parse_string_list " ") (Ok []) + (parse_string_list "(a\n ;coucou\n b)") (Ok [`List [`Atom "a"; `Atom "b"]]) + (parse_string_list "#; (a b) (c d) e ") (Ok [`List [`Atom "c"; `Atom "d"]; `Atom "e"]) + (parse_string_list "#; (a b) 1") (Ok [`Atom "1"]) *) @@ -392,7 +392,7 @@ include (Make(struct *) (*$Q & ~count:100 - sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = Result.Ok s)) + sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = Ok s)) *) let atom s : t = `Atom s diff --git a/src/sexp/CCSexp.mli b/src/sexp/CCSexp.mli index 54467f2d..856b5143 100644 --- a/src/sexp/CCSexp.mli +++ b/src/sexp/CCSexp.mli @@ -2,7 +2,7 @@ (** {1 Handling S-expressions} *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option diff --git a/src/sexp/CCSexp_intf.ml b/src/sexp/CCSexp_intf.ml index 16e4b3c6..aca01d63 100644 --- a/src/sexp/CCSexp_intf.ml +++ b/src/sexp/CCSexp_intf.ml @@ -1,5 +1,5 @@ -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a sequence = ('a -> unit) -> unit type 'a gen = unit -> 'a option diff --git a/src/unix/CCUnix.ml b/src/unix/CCUnix.ml index 905cd359..23692b0e 100644 --- a/src/unix/CCUnix.ml +++ b/src/unix/CCUnix.ml @@ -3,7 +3,7 @@ (** {1 High-level Functions on top of Unix} *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a gen = unit -> 'a option (** {2 Calling Commands} *) diff --git a/src/unix/CCUnix.mli b/src/unix/CCUnix.mli index 77657dd4..a66f32d9 100644 --- a/src/unix/CCUnix.mli +++ b/src/unix/CCUnix.mli @@ -8,7 +8,7 @@ {b status: unstable} @since 0.10 *) -type 'a or_error = ('a, string) Result.result +type 'a or_error = ('a, string) result type 'a gen = unit -> 'a option (** {2 Calling Commands} *) diff --git a/src/unlabel.ml b/src/unlabel.ml deleted file mode 100644 index 96048caf..00000000 --- a/src/unlabel.ml +++ /dev/null @@ -1,242 +0,0 @@ -(* search for first occurrence of pat in s *) -let rec search pat s pos = - let rec compare i = - if i >= String.length pat - then true - else if pat.[i] = s.[pos+i] - then compare (i+1) - else false - in - if pos > String.length s - String.length pat - then raise Not_found - else if compare 0 - then pos - else search pat s (pos+1) -;; - -(* search all non-overlapping occurrences of pat in s *) -let search_all pat s = - let rec search_rest acc pos = - let next = - try Some (search pat s pos) with - Not_found -> None - in - match next with - | None -> acc - | Some pos -> search_rest (pos::acc) (pos + String.length pat) - in - List.rev (search_rest [] 0) -;; - -(* replace first occurrence of pat with subst in s *) -let replace_first pat subst s = - let pos = search pat s 0 in - let patl = String.length pat - and substl = String.length subst in - let buf = Bytes.create (String.length s - patl + substl) in - Bytes.blit_string s 0 buf 0 pos; - Bytes.blit_string subst 0 buf pos substl; - Bytes.blit_string - s (pos + patl) - buf (pos + substl) - (String.length s - pos - patl); - Bytes.unsafe_to_string buf -;; - -(* replace all occurrences of pat with subst in s *) -let replace_all pat subst s = - let pos = search_all pat s in - let patl = String.length pat - and substl = String.length subst in - let len = String.length s + List.length pos * (substl - patl) in - let buf = Bytes.create len in - let rec loop src_pos dst_pos = function - | [] -> - Bytes.blit_string s src_pos buf dst_pos (String.length s - src_pos) - | pat_pos :: tail -> - let headl = pat_pos - src_pos in - Bytes.blit_string s src_pos buf dst_pos headl; - Bytes.blit_string subst 0 buf (dst_pos + headl) substl; - loop - (src_pos + headl + patl) - (dst_pos + headl + substl) - tail - in loop 0 0 pos; - Bytes.unsafe_to_string buf -;; - -let match_closeparen s i = - assert (s.[i] = ')'); - let rec loop i count = - match s.[i] with - | '(' when count = 0 -> i - | '(' -> loop (i-1) (count-1) - | ')' -> loop (i-1) (count+1) - | _ -> loop (i-1) count - in loop (i-1) 0 -;; - -let slurp_file file = - let ch = open_in file in - let buf = Buffer.create (min 1024 (in_channel_length ch)) in - try - while true do Buffer.add_channel buf ch 4096 done; - assert false - with - | End_of_file -> - close_in ch; - Bytes.unsafe_to_string (Buffer.to_bytes buf) -;; - -let () = - assert (Array.length Sys.argv = 3); - let labelled_filename = Sys.argv.(1) in (* CCArrayLabels.mli *) - let unlabelled_filename = Sys.argv.(2) in (* CCArray.ml *) - let labelled_name = (* ArrayLabels *) - assert (labelled_filename.[0] = 'C' && labelled_filename.[1] = 'C'); - let dot = String.rindex labelled_filename '.' in - String.sub labelled_filename 2 (dot - 2) - in - let unlabelled_name = (* Array *) - replace_first "Labels" "" labelled_name - in - let labelled_text = slurp_file labelled_filename in - let lexbuf = Lexing.from_string labelled_text in - Location.init lexbuf labelled_filename; - let labelled_ast = Parse.interface lexbuf in - (* stack of replacements to perform on the labelled_text. - * perform them in one run later so that the character counts - * won't be affected by earlier replacements. *) - let replacements = ref [] in - (* function removing '~' from docstring attributes where appropriate. *) - let strip_attributes labels attributes = - List.iter - begin function - | ({ Asttypes.txt = "ocaml.doc"; _ }, - Parsetree.PStr [{pstr_loc = - { loc_start = {pos_cnum = start; _} - ; loc_end = {pos_cnum = stop; _} - ; _} - ; _ - }]) -> - let docstring = - List.fold_left - (fun docstring label -> - replace_all ("~" ^ label) label docstring) - (String.sub labelled_text start (stop-start)) - labels - in - replacements := (start, stop-start, docstring) :: !replacements - | _ -> () - end - attributes - in - let iterator = - let open Ast_iterator in - let open Parsetree in - { Ast_iterator.default_iterator with - value_description = begin fun iterator - { pval_name = { txt = _name; _ } - ; pval_type - ; pval_prim = _ - ; pval_attributes - ; pval_loc - } -> - let rec loop = function - (* match function type with label *) - | { ptyp_desc = Ptyp_arrow (Labelled label, left, right) - ; ptyp_loc = {loc_start = {Lexing.pos_cnum = start; _}; _} - ; ptyp_attributes - ; _} - when - (* check that the argument type is not marked with [@keep_label] *) - List.for_all - (fun ({Asttypes.txt; _}, _) -> txt <> "keep_label") - left.ptyp_attributes - -> - assert (label = String.sub labelled_text start (String.length label)); - let colon = String.index_from labelled_text start ':' in - (* remove label *) - replacements := (start, colon+1-start, "") :: !replacements; - (* remove labels from associated docstrings *) - strip_attributes [label] ptyp_attributes; - label :: loop right - | { ptyp_desc = Ptyp_arrow (_, _left, right); _} -> - loop right - | _ -> [] - in - let labels = loop pval_type in - strip_attributes labels pval_attributes; - iterator.attributes iterator pval_attributes; - iterator.location iterator pval_loc; - iterator.typ iterator pval_type; - end - ; attribute = begin fun iterator - ({Asttypes.txt - ; loc = - { loc_start = {pos_cnum = start; _} - ; loc_end = {pos_cnum = stop; _} - ; _} as loc - }, _) -> - if txt = "keep_label" - then begin - (* start and stop positions mark the location of only the label name. - * Therefore search for enclosing brackets. *) - let start = String.rindex_from labelled_text start '[' - and stop = String. index_from labelled_text stop ']' in - (* remove leading ' ', too *) - let start = - if labelled_text.[start-1] = ' ' then start-1 else start - in - (* if a closing paren follows, remove this and the matching paren, - * this will hopefully be the right thing to do. *) - let stop = - if labelled_text.[stop+1] = ')' - then - let openp = match_closeparen labelled_text (stop+1) in - replacements := (openp, 1, "") :: !replacements; - stop+1 - else - stop - in - replacements := (start, stop-start+1, "") :: !replacements; - end; - iterator.location iterator loc - end - } - in - iterator.signature iterator labelled_ast; - - (* sort replacements in ascending order. *) - let replacements = - List.sort (fun (p1,_,_) (p2,_,_) -> compare p1 p2) !replacements - in - - (* perform the replacements by blitting to a buffer. *) - let unlabelled_text = Buffer.create (String.length labelled_text) in - List.fold_left begin fun start (pos,len,subst) -> - assert (pos >= start); - Buffer.add_substring unlabelled_text labelled_text start (pos - start); - Buffer.add_string unlabelled_text subst; - pos+len - end - 0 - replacements - |> fun start -> - Buffer.add_substring unlabelled_text - labelled_text start (String.length labelled_text - start); - - let unlabelled_text = - Buffer.contents unlabelled_text - (* ArrayLabels -> Array *) - |> replace_all labelled_name unlabelled_name - in - - let out = open_out unlabelled_filename in - output_string out ( - "(* AUTOGENERATED FROM " ^ - labelled_filename - ^ " *)\n\n"); - output_string out unlabelled_text; - close_out out; -;;