remove unlabel, remove all traces of Result

This commit is contained in:
Simon Cruanes 2019-12-10 20:48:38 -06:00
parent 30251e9426
commit 1b5b23a8f1
27 changed files with 160 additions and 361 deletions

View file

@ -709,3 +709,20 @@ module Infix = struct
let (--) = (--) let (--) = (--)
let (--^) = (--^) let (--^) = (--^)
end 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)
*)

View file

@ -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_gen a = _to_gen a.arr a.i a.j
let to_klist a = _to_klist 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)
*)

View file

@ -42,3 +42,18 @@ module Infix : sig
end end
include module type of Infix 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)
*)

View file

@ -418,8 +418,8 @@ module Dump = struct
let triple p1 p2 p3 = within "(" ")" (hovbox (triple p1 p2 p3)) 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 quad p1 p2 p3 p4 = within "(" ")" (hovbox (quad p1 p2 p3 p4))
let result' pok perror out = function let result' pok perror out = function
| Result.Ok x -> Format.fprintf out "(@[Ok %a@])" pok x | Ok x -> Format.fprintf out "(@[Ok %a@])" pok x
| Result.Error e -> Format.fprintf out "(@[Error %a@])" perror e | Error e -> Format.fprintf out "(@[Error %a@])" perror e
let result pok = result' pok string let result pok = result' pok string
let to_string = to_string let to_string = to_string
end end
@ -429,5 +429,5 @@ end
"Some 1" (to_string Dump.(option int) (Some 1)) "Some 1" (to_string Dump.(option int) (Some 1))
"[None;Some \"a b\"]" (to_string Dump.(list (option string)) [None; Some "a b"]) "[None;Some \"a b\"]" (to_string Dump.(list (option string)) [None; Some "a b"])
"[(Ok \"a b c\");(Error \"nope\")]" \ "[(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"])
*) *)

View file

@ -329,8 +329,8 @@ module Dump : sig
val quad : val quad :
'a t -> 'b t -> 'c t -> 'd t -> 'a t -> 'b t -> 'c t -> 'd t ->
('a * 'b * 'c * 'd) t ('a * 'b * 'c * 'd) t
val result : 'a t -> ('a, string) Result.result t val result : 'a t -> ('a, string) result t
val result' : 'a t -> 'e t -> ('a, 'e) Result.result t val result' : 'a t -> 'e t -> ('a, 'e) result t
val to_string : 'a t -> 'a -> string val to_string : 'a t -> 'a -> string
(** Alias to {!CCFormat.to_string}. *) (** Alias to {!CCFormat.to_string}. *)
end end

View file

@ -3,7 +3,7 @@
(** {1 IO Utils} *) (** {1 IO Utils} *)
type 'a or_error = ('a, string) Result.result type 'a or_error = ('a, string) result
type 'a gen = unit -> 'a option type 'a gen = unit -> 'a option
let gen_empty () = None let gen_empty () = None
@ -256,28 +256,28 @@ module File = struct
let remove_exn f = Sys.remove f let remove_exn f = Sys.remove f
let remove f = let remove f =
try Result.Ok (Sys.remove f) try Ok (Sys.remove f)
with exn -> 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_exn f = with_in f (read_all_ ~op:Ret_string ~size:4096)
let read f = 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 = let append_exn f x =
with_out ~flags:[Open_append; Open_creat; Open_text] f with_out ~flags:[Open_append; Open_creat; Open_text] f
(fun oc -> output_string oc x; flush oc) (fun oc -> output_string oc x; flush oc)
let append f x = 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 = let write_exn f x =
with_out f with_out f
(fun oc -> output_string oc x; flush oc) (fun oc -> output_string oc x; flush oc)
let write f x = 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 _ -> () let remove_noerr f = try Sys.remove f with _ -> ()

View file

@ -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 type 'a gen = unit -> 'a option
(** See [Gen] in the {{: https://github.com/c-cube/gen} gen library}. *) (** See [Gen] in the {{: https://github.com/c-cube/gen} gen library}. *)

View file

@ -1027,8 +1027,8 @@ let keep_some l = filter_map (fun x->x) l
let keep_ok l = let keep_ok l =
filter_map filter_map
(function (function
| Result.Ok x -> Some x | Ok x -> Some x
| Result.Error _ -> None) | Error _ -> None)
l l
let all_some l = let all_some l =
@ -1044,14 +1044,14 @@ let all_some l =
let all_ok l = let all_ok l =
let err = ref None in let err = ref None in
try try
Result.Ok Ok
(map (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) l)
with Exit -> with Exit ->
begin match !err with begin match !err with
| None -> assert false | None -> assert false
| Some e -> Result.Error e | Some e -> Error e
end end
let group_by (type k) ?(hash=Hashtbl.hash) ?(eq=Stdlib.(=)) l = 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) |> sort Stdlib.compare)
*) *)
(*$inject
open Result
*)
(*$= (*$=
(Ok []) (all_ok []) (Ok []) (all_ok [])
(Ok [1;2;3]) (all_ok [Ok 1; Ok 2; Ok 3]) (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]) [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)
*)

View file

@ -394,7 +394,7 @@ val keep_some : 'a option t -> 'a t
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @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]. (** [keep_ok l] retains only elements of the form [Ok x].
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @since 2.2 with labels *)
@ -405,7 +405,7 @@ val all_some : 'a option t -> 'a t option
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @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], (** [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). or [Error e] otherwise (with the first error met).
@since 1.3, but only @since 1.3, but only

View file

@ -392,7 +392,7 @@ val keep_some : 'a option t -> 'a t
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @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]. (** [keep_ok l] retains only elements of the form [Ok x].
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @since 2.2 with labels *)
@ -403,7 +403,7 @@ val all_some : 'a option t -> 'a t option
@since 1.3, but only @since 1.3, but only
@since 2.2 with labels *) @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], (** [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). or [Error e] otherwise (with the first error met).
@since 1.3, but only @since 1.3, but only

View file

@ -150,16 +150,16 @@ let of_list = function
| [] -> None | [] -> None
let to_result err = function let to_result err = function
| None -> Result.Error err | None -> Error err
| Some x -> Result.Ok x | Some x -> Ok x
let to_result_lazy err_fn = function let to_result_lazy err_fn = function
| None -> Result.Error (err_fn ()) | None -> Error (err_fn ())
| Some x -> Result.Ok x | Some x -> Ok x
let of_result = function let of_result = function
| Result.Error _ -> None | Error _ -> None
| Result.Ok x -> Some x | Ok x -> Some x
module Infix = struct module Infix = struct
let (>|=) = (>|=) let (>|=) = (>|=)

View file

@ -163,13 +163,13 @@ val to_list : 'a t -> 'a list
val of_list : 'a list -> 'a t val of_list : 'a list -> 'a t
(** Head of list, or [None]. *) (** 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 *) (** @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 *) (** @since 1.2 *)
val of_result : ('a, _) Result.result -> 'a t val of_result : ('a, _) result -> 'a t
(** @since 1.2 *) (** @since 1.2 *)
type 'a sequence = ('a -> unit) -> unit type 'a sequence = ('a -> unit) -> unit

View file

@ -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 line_num = int
type col_num = int type col_num = int
@ -443,10 +443,10 @@ let parse_exn p st =
| None -> assert false | None -> assert false
| Some x -> x | 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 = let parse p st =
try Result.Ok (parse_exn p st) try Ok (parse_exn p st)
with e -> exn_to_err e with e -> exn_to_err e
let parse_string_exn p s = parse_exn p (state_of_string s) 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 raise e
let parse_file p file = 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 with e -> exn_to_err e
module Infix = struct module Infix = struct

View file

@ -48,7 +48,7 @@
*) *)
type 'a or_error = ('a, string) Result.result type 'a or_error = ('a, string) result
type line_num = int type line_num = int
type col_num = int type col_num = int

View file

@ -9,9 +9,7 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Basics} *) (** {2 Basics} *)
include Result type (+'good, +'bad) t = ('good, 'bad) result =
type (+'good, +'bad) t = ('good, 'bad) Result.result =
| Ok of 'good | Ok of 'good
| Error of 'bad | Error of 'bad

View file

@ -13,10 +13,7 @@ type 'a printer = Format.formatter -> 'a -> unit
(** {2 Basics} *) (** {2 Basics} *)
include module type of struct include Result end type (+'good, +'bad) t = ('good, 'bad) result =
(** @since 1.5 *)
type (+'good, +'bad) t = ('good, 'bad) Result.result =
| Ok of 'good | Ok of 'good
| Error of 'bad | Error of 'bad

View file

@ -1162,3 +1162,18 @@ module Sub = struct
let pp fmt s = let pp fmt s =
Format.fprintf fmt "\"%s\"" (copy s) Format.fprintf fmt "\"%s\"" (copy s)
end 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)
*)

View file

@ -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 (executable
(name mkshims) (name mkshims)

View file

@ -80,6 +80,24 @@ let shims_array_pre_408 = "
" "
let shims_array_post_408 = "include Array" 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 () = let () =
C.main ~name:"mkshims" (fun c -> C.main ~name:"mkshims" (fun c ->
let version = C.ocaml_config_var_exn c "version" in let version = C.ocaml_config_var_exn c "version" in

View file

@ -3,11 +3,6 @@
(modules mkflags) (modules mkflags)
(libraries dune.configurator)) (libraries dune.configurator))
(executable
(name unlabel)
(modules unlabel)
(libraries compiler-libs.common))
(env (env
(_ (flags :standard -warn-error -3))) (_ (flags :standard -warn-error -3)))

View file

@ -4,6 +4,4 @@
(public_name containers.iter) (public_name containers.iter)
(wrapped false) (wrapped false)
(flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string) (flags :standard -w +a-4-42-44-48-50-58-32-60@8 -safe-string)
(ocamlopt_flags :standard (:include ../flambda.flags)) (ocamlopt_flags :standard (:include ../flambda.flags)))
(libraries dune)
)

View file

@ -4,7 +4,7 @@
open CCShims_ 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 sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option type 'a gen = unit -> 'a option
@ -134,7 +134,7 @@ module Make(Sexp : SEXP) = struct
x x
with e -> with e ->
close_in ic; 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, (** A parser of ['a] can return [Yield x] when it parsed a value,
or [Fail e] when a parse error was encountered, or 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 to_list (d:t) : _ or_error =
let rec iter acc = match next d with let rec iter acc = match next d with
| End -> Result.Ok (List.rev acc) | End -> Ok (List.rev acc)
| Yield x -> iter (x::acc) | Yield x -> iter (x::acc)
| Fail e -> Result.Error e | Fail e -> Error e
in in
try iter [] try iter []
with e -> Error (Printexc.to_string e) with e -> Error (Printexc.to_string e)
@ -244,9 +244,9 @@ module Make(Sexp : SEXP) = struct
let dec_next_ (d:Decoder.t) : _ or_error = let dec_next_ (d:Decoder.t) : _ or_error =
match Decoder.next d with match Decoder.next d with
| End -> Result.Error "unexpected end of file" | End -> Error "unexpected end of file"
| Yield x -> Result.Ok x | Yield x -> Ok x
| Fail s -> Result.Error s | Fail s -> Error s
let parse_string s : t or_error = let parse_string s : t or_error =
let buf = Lexing.from_string s in let buf = Lexing.from_string s in
@ -284,8 +284,8 @@ module Make(Sexp : SEXP) = struct
let d = Decoder.of_lexbuf buf in let d = Decoder.of_lexbuf buf in
fun () -> match Decoder.next d with fun () -> match Decoder.next d with
| End -> None | End -> None
| Fail e -> Some (Result.Error e) | Fail e -> Some (Error e)
| Yield x -> Some (Result.Ok x) | Yield x -> Some (Ok x)
let parse_file filename = _with_in filename (parse_chan_ ~file:filename) 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 CCResult.to_opt (parse_string "\"\123\bcoucou\"") <> None
*) *)
(*$= & ~printer:(function Result.Ok x -> to_string x | Result.Error e -> "error " ^ e) (*$= & ~printer:(function Ok x -> to_string x | Error e -> "error " ^ e)
(parse_string "(a b)") (Result.Ok (`List [`Atom "a"; `Atom "b"])) (parse_string "(a b)") (Ok (`List [`Atom "a"; `Atom "b"]))
(parse_string "(a\n ;coucou\n b)") (Result.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)") (Result.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)") (Result.Ok (`List [`Atom "c"; `Atom "d"])) (parse_string "#; (a b) (c d)") (Ok (`List [`Atom "c"; `Atom "d"]))
(parse_string "#; (a b) 1") (Result.Ok (`Atom "1")) (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) (*$= & ~printer:(function Ok x -> String.concat ";" @@ List.map to_string x | Error e -> "error " ^ e)
(parse_string_list "(a b)(c)") (Result.Ok [`List [`Atom "a"; `Atom "b"]; `List [`Atom "c"]]) (parse_string_list "(a b)(c)") (Ok [`List [`Atom "a"; `Atom "b"]; `List [`Atom "c"]])
(parse_string_list " ") (Result.Ok []) (parse_string_list " ") (Ok [])
(parse_string_list "(a\n ;coucou\n b)") (Result.Ok [`List [`Atom "a"; `Atom "b"]]) (parse_string_list "(a\n ;coucou\n b)") (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) (c d) e ") (Ok [`List [`Atom "c"; `Atom "d"]; `Atom "e"])
(parse_string_list "#; (a b) 1") (Result.Ok [`Atom "1"]) (parse_string_list "#; (a b) 1") (Ok [`Atom "1"])
*) *)
@ -392,7 +392,7 @@ include (Make(struct
*) *)
(*$Q & ~count:100 (*$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 let atom s : t = `Atom s

View file

@ -2,7 +2,7 @@
(** {1 Handling S-expressions} *) (** {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 sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option type 'a gen = unit -> 'a option

View file

@ -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 sequence = ('a -> unit) -> unit
type 'a gen = unit -> 'a option type 'a gen = unit -> 'a option

View file

@ -3,7 +3,7 @@
(** {1 High-level Functions on top of Unix} *) (** {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 type 'a gen = unit -> 'a option
(** {2 Calling Commands} *) (** {2 Calling Commands} *)

View file

@ -8,7 +8,7 @@
{b status: unstable} {b status: unstable}
@since 0.10 *) @since 0.10 *)
type 'a or_error = ('a, string) Result.result type 'a or_error = ('a, string) result
type 'a gen = unit -> 'a option type 'a gen = unit -> 'a option
(** {2 Calling Commands} *) (** {2 Calling Commands} *)

View file

@ -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;
;;