From d83e1f758478eb0168ab3c83eff3e7d5bcd3c8c9 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 18 Oct 2018 14:34:18 +0200 Subject: [PATCH 1/5] Abstract away the notion of mark. --- src/tyre.ml | 46 ++++++++++++++++++++++++++++++++-------------- src/tyre.mli | 8 +++++--- 2 files changed, 37 insertions(+), 17 deletions(-) diff --git a/src/tyre.ml b/src/tyre.ml index 64f9447..91713bb 100644 --- a/src/tyre.ml +++ b/src/tyre.ml @@ -28,10 +28,24 @@ module Seq = struct let to_list gen = List.rev (to_rev_list gen) end -let map_3 f (x,y,z) = (x, y, f z) - (** {2 The various types} *) +module type IDX = sig + type t + val mark : int * 'a * Re.t -> int * 'a * t * Re.t + val test : Re.Group.t -> t -> bool +end + +module MarkIdx : IDX = struct + type t = Re.markid + let mark (i,w,re) = + let idx, re = Re.mark re in + (i, w, idx, re) + let test = Re.Mark.test +end + +module Idx = MarkIdx + module T = struct type ('a, 'b) conv = { @@ -54,8 +68,8 @@ module T = struct type _ wit = | Lit : int -> string wit | Conv : 'a wit * ('a, 'b) conv -> 'b wit - | Opt : Re.Mark.t * 'a wit -> 'a option wit - | Alt : Re.Mark.t * 'a wit * 'b wit + | Opt : Idx.t * 'a wit -> 'a option wit + | Alt : Idx.t * 'a wit * Idx.t * 'b wit -> [`Left of 'a | `Right of 'b] wit | Seq : 'a wit * 'b wit -> ('a * 'b) wit @@ -264,12 +278,12 @@ let rec build let i', w, re = build i e in i', Conv (w, conv), re | Opt e -> - let i', w, (id, re) = map_3 mark @@ build i e in + let i', w, id, re = Idx.mark @@ build i e in i', Opt (id,w), opt re | Alt (e1,e2) -> - let i', w1, (id1, re1) = map_3 mark @@ build i e1 in - let i'', w2, re2 = build i' e2 in - i'', Alt (id1, w1, w2), alt [re1 ; re2] + let i', w1, id1, re1 = Idx.mark @@ build i e1 in + let i'', w2, id2, re2 = Idx.mark @@ build i' e2 in + i'', Alt (id1, w1, id2, w2), alt [re1 ; re2] | Prefix (e_ign,e) -> let i', w, re = build i e in let _, _, re_ign = build 1 e_ign in @@ -304,14 +318,17 @@ let[@specialize] rec extract let v = extract ~original w s in conv.to_ v | Opt (id,w) -> - if not @@ Re.Mark.test s id then None + if not @@ Idx.test s id then None else Some (extract ~original w s) - | Alt (i1,w1,w2) -> - if Re.Mark.test s i1 then + | Alt (i1,w1,i2,w2) -> + if Idx.test s i1 then `Left (extract ~original w1 s) - else - (* Invariant: Alt produces [Re.alt [e1 ; e2]] *) + else if Idx.test s i2 then `Right (extract ~original w2 s) + else + (* If neither matches, it means it's the empty string, we can + default to the left *) + `Left (extract ~original w1 s) | Seq (e1,e2) -> let v1 = extract ~original e1 s in let v2 = extract ~original e2 s in @@ -451,7 +468,7 @@ let rec pp_wit | Lit i -> sexp ppf "Lit" "%i" i | Conv (tre,_) -> sexp ppf "Conv" "%a" pp_wit tre | Opt (_, tre) -> sexp ppf "Opt" "%a" pp_wit tre - | Alt (_, tre1, tre2) -> sexp ppf "Alt" "%a@ %a" pp_wit tre1 pp_wit tre2 + | Alt (_, tre1, _, tre2) -> sexp ppf "Alt" "%a@ %a" pp_wit tre1 pp_wit tre2 | Seq (tre1 ,tre2) -> sexp ppf "Seq" "%a@ %a" pp_wit tre1 pp_wit tre2 | Rep (i, w, re) -> sexp ppf "Rep" "%i@ %a@ %a" i pp_wit w Re.pp_re re @@ -472,6 +489,7 @@ let pp_error ppf : _ error -> unit = function Format.pp_print_string ppf @@ Printexc.to_string exn module Internal = struct + type idx = Idx.t include T let to_t x = x diff --git a/src/tyre.mli b/src/tyre.mli index 8849793..f5ca59c 100644 --- a/src/tyre.mli +++ b/src/tyre.mli @@ -287,6 +287,8 @@ module Internal : sig from_ : 'b -> 'a ; } + type idx + type 'a raw = (* We store a compiled regex to efficiently check string when unparsing. *) | Regexp : Re.t * Re.re Lazy.t -> string raw @@ -305,9 +307,9 @@ module Internal : sig type _ wit = | Lit : int -> string wit | Conv : 'a wit * ('a, 'b) conv -> 'b wit - | Opt : Re.Mark.t * 'a wit -> 'a option wit - | Alt : Re.Mark.t * 'a wit * 'b wit - -> [`Left of 'a | `Right of 'b] wit + | Opt : idx * 'a wit -> 'a option wit + | Alt : idx * 'a wit * idx * + 'b wit -> [ `Left of 'a | `Right of 'b ] wit | Seq : 'a wit * 'b wit -> ('a * 'b) wit | Rep : int * 'a wit * Re.re -> 'a Seq.t wit From 1021a3d7b6048250a3e5560b9c8a1423d5a6a072 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 18 Oct 2018 15:15:32 +0200 Subject: [PATCH 2/5] Small test improvements. --- test/test.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/test/test.ml b/test/test.ml index 378883e..3440098 100644 --- a/test/test.ml +++ b/test/test.ml @@ -53,13 +53,13 @@ let convfail title desc re s = let test title desc cre re v s = A.(check @@ tyre desc) - (title^" exec") (Tyre.exec cre s) (Result.Ok v) ; - A.(check bool) (title^" execp") (Tyre.execp cre s) true ; + (title^" exec") (Result.Ok v) (Tyre.exec cre s) ; + A.(check bool) (title^" execp") true (Tyre.execp cre s) ; A.(check string) (title^" eval") s (Tyre.eval re v) let test_all title desc cre re l s = A.(check @@ tyre @@ list desc) - (title^" all") (Tyre.all cre s) (Result.Ok l) ; + (title^" all") (Result.Ok l) (Tyre.all cre s) ; A.(check string) (title^" eval all") s (Tyre.eval (list re) l) let t' ?(all=true) title desc re v s = @@ -97,6 +97,9 @@ let basics = [ topt "int option" A.int (opt int) 3 "3" "" ; t "int seq" A.(pair int bool) (int <&> bool) (3,true) "3true" ; + + t "list" A.(list string) (list @@ pcre "a|b") ["a";"b";"a";"a"] "abaa"; + t' "separated list" A.(list int) (separated_list ~sep:(char ',') int) [4;4;4] "4,4,4" ; ] let notwhole = [ From 76c4eadbe3aae32e9bd5b94f1aa5569a125f82f4 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 18 Oct 2018 15:15:48 +0200 Subject: [PATCH 3/5] Implement mark with groups. --- src/tyre.ml | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src/tyre.ml b/src/tyre.ml index 91713bb..955673f 100644 --- a/src/tyre.ml +++ b/src/tyre.ml @@ -32,17 +32,27 @@ end module type IDX = sig type t - val mark : int * 'a * Re.t -> int * 'a * t * Re.t + val with_mark : + (int -> 'b -> 'c * 'd * Re.t) -> int -> 'b -> 'c * 'd * t * Re.t val test : Re.Group.t -> t -> bool end module MarkIdx : IDX = struct - type t = Re.markid - let mark (i,w,re) = + type t = Re.Mark.t + let with_mark f i re = + let i, w, re = f i re in let idx, re = Re.mark re in - (i, w, idx, re) + i, w, idx, re let test = Re.Mark.test end +module GroupIdx : IDX = struct + type t = int + let with_mark f i re = + let i', w, re = f (i+1) re in + let re = Re.group re in + i', w, i, re + let test = Re.Group.test +end module Idx = MarkIdx @@ -278,11 +288,11 @@ let rec build let i', w, re = build i e in i', Conv (w, conv), re | Opt e -> - let i', w, id, re = Idx.mark @@ build i e in + let i', w, id, re = Idx.with_mark build i e in i', Opt (id,w), opt re | Alt (e1,e2) -> - let i', w1, id1, re1 = Idx.mark @@ build i e1 in - let i'', w2, id2, re2 = Idx.mark @@ build i' e2 in + let i', w1, id1, re1 = Idx.with_mark build i e1 in + let i'', w2, id2, re2 = Idx.with_mark build i' e2 in i'', Alt (id1, w1, id2, w2), alt [re1 ; re2] | Prefix (e_ign,e) -> let i', w, re = build i e in From e02ac7a5a00b2d7816f90a00daf9145408809713 Mon Sep 17 00:00:00 2001 From: Drup Date: Fri, 6 Jul 2018 23:34:05 +0200 Subject: [PATCH 4/5] Functorize the Re part. --- src/tyre.ml | 205 +++++++++++++++++++++++++++++++++------------------- 1 file changed, 129 insertions(+), 76 deletions(-) diff --git a/src/tyre.ml b/src/tyre.ml index 955673f..5ba3477 100644 --- a/src/tyre.ml +++ b/src/tyre.ml @@ -31,13 +31,15 @@ end (** {2 The various types} *) module type IDX = sig + type re + type group type t val with_mark : - (int -> 'b -> 'c * 'd * Re.t) -> int -> 'b -> 'c * 'd * t * Re.t - val test : Re.Group.t -> t -> bool + (int -> 'b -> 'c * 'd * re) -> int -> 'b -> 'c * 'd * t * re + val test : group -> t -> bool end -module MarkIdx : IDX = struct +module MarkIdx : IDX with type re := Re.t and type group := Re.Group.t = struct type t = Re.Mark.t let with_mark f i re = let i, w, re = f i re in @@ -45,7 +47,7 @@ module MarkIdx : IDX = struct i, w, idx, re let test = Re.Mark.test end -module GroupIdx : IDX = struct +module GroupIdx : IDX with type re := Re.t and type group := Re.Group.t = struct type t = int let with_mark f i re = let i', w, re = f (i+1) re in @@ -54,7 +56,45 @@ module GroupIdx : IDX = struct let test = Re.Group.test end -module Idx = MarkIdx +module type S = sig + + type t + val pp : Format.formatter -> t -> unit + + val whole_string : t -> t + val no_group : t -> t + val group : t -> t + val seq : t list -> t + val alt : t list -> t + val opt : t -> t + val rep : t -> t + + (** Compilation *) + type re + val pp_re : Format.formatter -> re -> unit + val compile : t -> re + + (** Witness *) + type string + val pp_string : Format.formatter -> string -> unit + val witness : t -> string + + (** Matching *) + module Group : sig + type t + val get : t -> int -> string + val offset : t -> int -> int * int + end + + val exec : ?pos:int -> ?len:int -> re -> string -> Group.t option + val all : ?pos:int -> ?len:int -> re -> string -> Group.t Seq.t + val test : ?pos:int -> ?len:int -> re -> string -> bool +end + +module Make + (Re : S) + (Idx : IDX with type re := Re.t and type group := Re.Group.t) += struct module T = struct @@ -65,7 +105,7 @@ module T = struct type 'a raw = (* We store a compiled regex to efficiently check string when unparsing. *) - | Regexp : Re.t * Re.re Lazy.t -> string raw + | Regexp : Re.t * Re.re Lazy.t -> Re.string raw | Conv : 'a raw * ('a, 'b) conv -> 'b raw | Opt : 'a raw -> ('a option) raw | Alt : 'a raw * 'b raw -> [`Left of 'a | `Right of 'b] raw @@ -76,7 +116,7 @@ module T = struct | Mod : (Re.t -> Re.t) * 'a raw -> 'a raw type _ wit = - | Lit : int -> string wit + | Lit : int -> Re.string wit | Conv : 'a wit * ('a, 'b) conv -> 'b wit | Opt : Idx.t * 'a wit -> 'a option wit | Alt : Idx.t * 'a wit * Idx.t * 'b wit @@ -93,8 +133,6 @@ let regex x : _ t = let re = lazy Re.(compile @@ whole_string @@ no_group x) in Regexp (x, re) -let pcre s = regex @@ Re.Pcre.re s - (* Converters The exception matching of converters is handled by {!Tyre.exec} directly. @@ -128,64 +166,12 @@ let rep1 x = x <&> rep x *) let modifier f re : _ t = Mod (f, re) -let word re = modifier Re.word re -let whole_string re = modifier Re.whole_string re -let longest re = modifier Re.longest re -let shortest re = modifier Re.shortest re -let first re = modifier Re.first re -let greedy re = modifier Re.greedy re -let non_greedy re = modifier Re.non_greedy re -let nest re = modifier Re.nest re - -module Regex = struct - open! Re - - (** [0-9]+ *) - let pos_int = rep1 digit - - (** -?[0-9]+ *) - let int = - seq [opt (char '-') ; pos_int] - - (** -?[0-9]+( .[0-9]* )? *) - let float = - seq [opt (char '-') ; rep1 digit ; opt (seq [char '.'; rep digit])] - - (** true|false *) - let bool = - alt [str "true" ; str "false"] - -end - let unit s re = conv (fun _ -> ()) (fun () -> s) (regex re) -let start = unit "" Re.start -let stop = unit "" Re.stop - -let str s = unit s (Re.str s) - -let char c = - let s = String.make 1 c in - unit s (Re.char c) - -let blanks = unit "" (Re.rep Re.blank) - -let pos_int = - conv int_of_string string_of_int (regex Regex.pos_int) - -let int = - conv int_of_string string_of_int (regex Regex.int) - -let float = - conv float_of_string string_of_float (regex Regex.float) - -let bool = - conv bool_of_string string_of_bool (regex Regex.bool) - let list e = conv Seq.to_list Seq.of_list (rep e) @@ -210,7 +196,7 @@ let separated_list ~sep e = let rec witnesspp : type a . Format.formatter -> a t -> unit = fun ppf tre -> let open T in match tre with - | Regexp (re, _) -> Format.pp_print_string ppf @@ Re.witness re + | Regexp (re, _) -> Re.pp_string ppf @@ Re.witness re | Conv (tre, _) -> witnesspp ppf tre | Opt _ -> () | Alt (tre1, _) -> witnesspp ppf tre1 @@ -231,7 +217,7 @@ let rec witnesspp (** Evaluation is the act of filling the holes. *) -let pstr = Format.pp_print_string +let pstr = Re.pp_string let rec pprep f ppf seq = match seq () with | Seq.Nil -> () | Cons (x, seq) -> f ppf x ; pprep f ppf seq @@ -240,14 +226,15 @@ let rec evalpp : type a . a t -> Format.formatter -> a -> unit = fun tre ppf -> let open T in match tre with | Regexp (_, lazy cre) -> begin function v -> - if not @@ Re.execp cre v then + if not @@ Re.test cre v then invalid_arg @@ - Printf.sprintf "Tyre.eval: regexp not respected by \"%s\"." v ; + Format.asprintf "Tyre.eval: regexp not respected by \"%a\"." + Re.pp_string v ; pstr ppf v end | Conv (tre, conv) -> fun v -> evalpp tre ppf (conv.from_ v) | Opt p -> begin function - | None -> pstr ppf "" + | None -> () | Some x -> evalpp p ppf x end | Seq (tre1,tre2) -> fun (x1, x2) -> @@ -321,7 +308,7 @@ let rec build To avoid copy, we pass around the original string (and we use positions). *) let[@specialize] rec extract - : type a. original:string -> a T.wit -> Re.Group.t -> a + : type a. original:Re.string -> a T.wit -> Re.Group.t -> a = fun ~original rea s -> let open T in match rea with | Lit i -> Re.Group.get s i | Conv (w, conv) -> @@ -352,12 +339,12 @@ let[@specialize] rec extract possible as it would be equivalent to counting in an automaton). *) and[@specialize] extract_list - : type a. original:string -> a T.wit -> Re.re -> int -> Re.Group.t -> a Seq.t + : type a. original:Re.string -> a T.wit -> Re.re -> int -> Re.Group.t -> a Seq.t = fun ~original e re i s -> let aux = extract ~original e in let (pos, pos') = Re.Group.offset s i in let len = pos' - pos in - Seq.map aux @@ Re.Seq.all ~pos ~len re original + Seq.map aux @@ Re.all ~pos ~len re original (** {4 Multiple match} *) @@ -368,7 +355,7 @@ let route re f = Route (re, f) let (-->) = route type 'r wit_route = - WRoute : Re.Mark.t * 'a T.wit * ('a -> 'r) -> 'r wit_route + WRoute : Idx.t * 'a T.wit * ('a -> 'r) -> 'r wit_route (* It's important to keep the order here, since Re will choose the first regexp if there is ambiguity. @@ -376,8 +363,7 @@ type 'r wit_route = let rec build_route_aux i rel wl = function | [] -> List.rev rel, List.rev wl | Route (tre, f) :: l -> - let i', wit, re = build i tre in - let id, re = Re.mark re in + let i', wit, id, re = Idx.with_mark build i tre in let w = WRoute (id, wit, f) in build_route_aux i' (re::rel) (w::wl) l @@ -388,7 +374,7 @@ let rec extract_route ~original wl subs = match wl with (* Invariant: At least one of the regexp of the alternative matches. *) assert false | WRoute (id, wit, f) :: wl -> - if Re.Mark.test subs id then + if Idx.test subs id then f (extract ~original wit subs) else extract_route ~original wl subs @@ -422,7 +408,7 @@ let extract_with_info ~info ~original subs = match info with | Routes wl -> extract_route ~original wl subs let[@inline] exec ?pos ?len ({ info ; cre } as tcre) original = - match Re.exec_opt ?pos ?len cre original with + match Re.exec ?pos ?len cre original with | None -> Result.Error (`NoMatch (tcre, original)) | Some subs -> try @@ -431,10 +417,10 @@ let[@inline] exec ?pos ?len ({ info ; cre } as tcre) original = Result.Error (`ConverterFailure exn) let execp ?pos ?len {cre ; _ } original = - Re.execp ?pos ?len cre original + Re.test ?pos ?len cre original let all_seq ?pos ?len { info ; cre } original = - let seq = Re.Seq.all ?pos ?len cre original in + let seq = Re.all ?pos ?len cre original in let get_res subs = extract_with_info ~info ~original subs in Seq.map get_res seq @@ -508,3 +494,70 @@ module Internal = struct let build = build let extract = extract end + +end + +include Make(struct + include Re + + type string = String.t + let pp_string = Format.pp_print_string + + let exec = exec_opt + let all = Seq.all + let test = execp + end)(MarkIdx) + +let pcre s = regex @@ Re.Pcre.re s + +let word re = modifier Re.word re +let whole_string re = modifier Re.whole_string re +let longest re = modifier Re.longest re +let shortest re = modifier Re.shortest re +let first re = modifier Re.first re +let greedy re = modifier Re.greedy re +let non_greedy re = modifier Re.non_greedy re +let nest re = modifier Re.nest re + +module Regex = struct + open! Re + + (** [0-9]+ *) + let pos_int = rep1 digit + + (** -?[0-9]+ *) + let int = + seq [opt (char '-') ; pos_int] + + (** -?[0-9]+( .[0-9]* )? *) + let float = + seq [opt (char '-') ; rep1 digit ; opt (seq [char '.'; rep digit])] + + (** true|false *) + let bool = + alt [str "true" ; str "false"] + +end + +let start = unit "" Re.start +let stop = unit "" Re.stop + +let str s = unit s (Re.str s) + +let char c = + let s = String.make 1 c in + unit s (Re.char c) + +let blanks = unit "" (Re.rep Re.blank) + +let pos_int = + conv int_of_string string_of_int (regex Regex.pos_int) + +let int = + conv int_of_string string_of_int (regex Regex.int) + +let float = + conv float_of_string string_of_float (regex Regex.float) + +let bool = + conv bool_of_string string_of_bool (regex Regex.bool) From 936f63675adf2fd7945b1fe26db5a896bf19cb2a Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 18 Oct 2018 16:16:03 +0200 Subject: [PATCH 5/5] Reorganize the library. --- src/core.ml | 19 ++ src/dune | 12 +- src/functor.ml | 404 ++++++++++++++++++++++++++++++++++++++++ src/impl.ml | 17 ++ src/sigs.mli | 40 ++++ src/tyre.ml | 487 +------------------------------------------------ src/tyrefun.ml | 4 + 7 files changed, 499 insertions(+), 484 deletions(-) create mode 100644 src/core.ml create mode 100644 src/functor.ml create mode 100644 src/impl.ml create mode 100644 src/sigs.mli create mode 100644 src/tyrefun.ml diff --git a/src/core.ml b/src/core.ml new file mode 100644 index 0000000..6eb72f7 --- /dev/null +++ b/src/core.ml @@ -0,0 +1,19 @@ + +type ('a, 'b) conv = { + to_ : 'a -> 'b ; + from_ : 'b -> 'a ; +} + +module Seq = struct + include Seq + + let of_list l = + let rec aux l () = match l with + | [] -> Seq.Nil + | x :: tail -> Seq.Cons (x, aux tail) + in + aux l + let to_rev_list gen = + fold_left (fun acc x -> x :: acc) [] gen + let to_list gen = List.rev (to_rev_list gen) +end diff --git a/src/dune b/src/dune index 36e5e9a..28368b3 100644 --- a/src/dune +++ b/src/dune @@ -3,5 +3,15 @@ (public_name tyre) (synopsis "Tyre is a set of combinators to build type-safe regular expressions") - (libraries re result seq) + (libraries re tyrefun) + (modules Tyre Impl) (ocamlopt_flags :standard -O3)) + +(library + (name tyrefun) + (public_name tyre.fun) + (libraries result seq) + (modules_without_implementation sigs) + (modules Tyrefun Core Functor Sigs) + (ocamlopt_flags :standard -O3) +) diff --git a/src/functor.ml b/src/functor.ml new file mode 100644 index 0000000..ad9a6ac --- /dev/null +++ b/src/functor.ml @@ -0,0 +1,404 @@ +open Core + +module Make (Re : Sigs.S) = struct + + module T = struct + + type ('a, 'b) conv = ('a, 'b) Core.conv = { + to_ : 'a -> 'b ; + from_ : 'b -> 'a ; + } + + type 'a raw = + (* We store a compiled regex to efficiently check string when unparsing. *) + | Regexp : Re.t * Re.re Lazy.t -> Re.string raw + | Conv : 'a raw * ('a, 'b) conv -> 'b raw + | Opt : 'a raw -> ('a option) raw + | Alt : 'a raw * 'b raw -> [`Left of 'a | `Right of 'b] raw + | Seq : 'a raw * 'b raw -> ('a * 'b) raw + | Prefix : 'b raw * 'a raw -> 'a raw + | Suffix : 'a raw * 'b raw -> 'a raw + | Rep : 'a raw -> 'a Seq.t raw + | Mod : (Re.t -> Re.t) * 'a raw -> 'a raw + + type _ wit = + | Lit : int -> Re.string wit + | Conv : 'a wit * ('a, 'b) conv -> 'b wit + | Opt : Re.Idx.idx * 'a wit -> 'a option wit + | Alt : Re.Idx.idx * 'a wit * Re.Idx.idx * 'b wit + -> [`Left of 'a | `Right of 'b] wit + | Seq : + 'a wit * 'b wit -> ('a * 'b) wit + | Rep : int * 'a wit * Re.re -> 'a Seq.t wit + + end + + type 'a t = 'a T.raw + + let regex x : _ t = + let re = lazy Re.(compile @@ whole_string @@ no_group x) in + Regexp (x, re) + + (* Converters + + The exception matching of converters is handled by {!Tyre.exec} directly. + *) + let conv to_ from_ x : _ t = + Conv (x, {to_; from_}) + + let seq a b : _ t = Seq (a, b) + let alt a b : _ t = Alt (a, b) + + let prefix x a : _ t = Prefix (x, a) + let suffix a x : _ t = Suffix (a, x) + let opt a : _ t = Opt a + + module Infix = struct + + let (<|>) = alt + let (<&>) = seq + + let ( *>) = prefix + let (<* ) = suffix + + end + include Infix + + let rep x : _ t = Rep x + let rep1 x = x <&> rep x + + (* [modifier] is unsafe in general (for example [modifier Re.group]). + It shouldn't be exposed to the user. + *) + let modifier f re : _ t = Mod (f, re) + + let unit s re = + conv + (fun _ -> ()) + (fun () -> s) + (regex re) + + let list e = + conv Seq.to_list Seq.of_list (rep e) + + let terminated_list ~sep e = list (e <* sep) + let separated_list ~sep e = + let e = opt (e <&> list (sep *> e)) in + let to_ = function None -> [] | Some (h, t) -> (h :: t) + and from_ = function [] -> None | h :: t -> Some (h, t) + in + conv to_ from_ e + + + (** {2 Witness} *) + + (** A witness is a string such that [exec (compile re) (witness re) = true]. + The computation of the witness is deterministic and should result in + a small example. + + It is used in [eval] for the part of the regex that are ignored. + *) + + let rec witnesspp + : type a . Format.formatter -> a t -> unit + = fun ppf tre -> let open T in match tre with + | Regexp (re, _) -> Re.pp_string ppf @@ Re.witness re + | Conv (tre, _) -> witnesspp ppf tre + | Opt _ -> () + | Alt (tre1, _) -> witnesspp ppf tre1 + | Seq (tre1, tre2) -> + witnesspp ppf tre1 ; + witnesspp ppf tre2 + | Prefix (tre1,tre2) -> + witnesspp ppf tre1 ; + witnesspp ppf tre2 + | Suffix (tre1,tre2) -> + witnesspp ppf tre1 ; + witnesspp ppf tre2 + | Rep _ -> () + | Mod (_,tre) -> + witnesspp ppf tre + + (** {2 Evaluation functions} *) + + (** Evaluation is the act of filling the holes. *) + + let pstr = Re.pp_string + let rec pprep f ppf seq = match seq () with + | Seq.Nil -> () + | Cons (x, seq) -> f ppf x ; pprep f ppf seq + + let rec evalpp + : type a . a t -> Format.formatter -> a -> unit + = fun tre ppf -> let open T in match tre with + | Regexp (_, lazy cre) -> begin function v -> + if not @@ Re.test cre v then + invalid_arg @@ + Format.asprintf "Tyre.eval: regexp not respected by \"%a\"." + Re.pp_string v ; + pstr ppf v + end + | Conv (tre, conv) -> fun v -> evalpp tre ppf (conv.from_ v) + | Opt p -> begin function + | None -> () + | Some x -> evalpp p ppf x + end + | Seq (tre1,tre2) -> fun (x1, x2) -> + evalpp tre1 ppf x1 ; + evalpp tre2 ppf x2 ; + | Prefix(tre_l,tre) -> + fun v -> witnesspp ppf tre_l ; evalpp tre ppf v + | Suffix(tre,tre_g) -> + fun v -> evalpp tre ppf v ; witnesspp ppf tre_g + | Alt (treL, treR) -> begin function + | `Left x -> evalpp treL ppf x + | `Right x -> evalpp treR ppf x + end + | Rep tre -> + pprep (evalpp tre) ppf + | Mod (_, tre) -> evalpp tre ppf + + let eval tre = Format.asprintf "%a" (evalpp tre) + + (** {2 matching} *) + + (** {3 Regexp construction} + + In order to record how we constructed the regexp and how to later + extract information, we build a witness containing all the tools we need. + + Each alternative is marked with {!Re.mark}. We store the markid in order + to be able to guess the branch matched. + *) + + let rec build + : type a. int -> a t -> int * a T.wit * Re.t + = let open! Re in let open T in + fun i -> function + | Regexp (re, _) -> + (i+1), Lit i, group @@ no_group re + | Conv (e, conv) -> + let i', w, re = build i e in + i', Conv (w, conv), re + | Opt e -> + let i', w, id, re = Idx.with_mark build i e in + i', Opt (id,w), opt re + | Alt (e1,e2) -> + let i', w1, id1, re1 = Idx.with_mark build i e1 in + let i'', w2, id2, re2 = Idx.with_mark build i' e2 in + i'', Alt (id1, w1, id2, w2), alt [re1 ; re2] + | Prefix (e_ign,e) -> + let i', w, re = build i e in + let _, _, re_ign = build 1 e_ign in + i', w, seq [no_group re_ign ; re] + | Suffix (e,e_ign) -> + let i', w, re = build i e in + let _, _, re_ign = build 1 e_ign in + i', w, seq [re ; no_group re_ign] + | Seq (e1,e2) -> + let i', w1, re1 = build i e1 in + let i'', w2, re2 = build i' e2 in + i'', Seq (w1, w2), seq [re1; re2] + | Rep e -> + let _, w, re = build 1 e in + (i+1), Rep (i,w,Re.compile re), group @@ rep @@ no_group re + | Mod (f, e) -> + let i', w, re = build i e in + i', w, f re + + (** {3 Extraction.} *) + + (** Extracting is just a matter of following the witness. + We just need to take care of counting where we are in the matching groups. + + To avoid copy, we pass around the original string (and we use positions). + *) + let[@specialize] rec extract + : type a. original:Re.string -> a T.wit -> Re.Group.t -> a + = fun ~original rea s -> let open T in match rea with + | Lit i -> Re.Group.get s i + | Conv (w, conv) -> + let v = extract ~original w s in + conv.to_ v + | Opt (id,w) -> + if not @@ Re.Idx.test s id then None + else Some (extract ~original w s) + | Alt (i1,w1,i2,w2) -> + if Re.Idx.test s i1 then + `Left (extract ~original w1 s) + else if Re.Idx.test s i2 then + `Right (extract ~original w2 s) + else + (* If neither matches, it means it's the empty string, we can + default to the left *) + `Left (extract ~original w1 s) + | Seq (e1,e2) -> + let v1 = extract ~original e1 s in + let v2 = extract ~original e2 s in + (v1, v2) + | Rep (i,e,re) -> extract_list ~original e re i s + + (** We need to re-match the string for lists, in order to extract + all the elements. + Re doesn't offer the possibility to keep the results when + grouping under a star (one could argue it's theoretically not + possible as it would be equivalent to counting in an automaton). + *) + and[@specialize] extract_list + : type a. original:Re.string -> a T.wit -> Re.re -> int -> Re.Group.t -> a Seq.t + = fun ~original e re i s -> + let aux = extract ~original e in + let (pos, pos') = Re.Group.offset s i in + let len = pos' - pos in + Seq.map aux @@ Re.all ~pos ~len re original + + (** {4 Multiple match} *) + + type +'r route = Route : 'a t * ('a -> 'r) -> 'r route + + let route re f = Route (re, f) + + let (-->) = route + + type 'r wit_route = + WRoute : Re.Idx.idx * 'a T.wit * ('a -> 'r) -> 'r wit_route + + (* It's important to keep the order here, since Re will choose + the first regexp if there is ambiguity. + *) + let rec build_route_aux i rel wl = function + | [] -> List.rev rel, List.rev wl + | Route (tre, f) :: l -> + let i', wit, id, re = Re.Idx.with_mark build i tre in + let w = WRoute (id, wit, f) in + build_route_aux i' (re::rel) (w::wl) l + + let build_route l = build_route_aux 1 [] [] l + + let rec extract_route ~original wl subs = match wl with + | [] -> + (* Invariant: At least one of the regexp of the alternative matches. *) + assert false + | WRoute (id, wit, f) :: wl -> + if Re.Idx.test subs id then + f (extract ~original wit subs) + else + extract_route ~original wl subs + + (** {4 Compilation and execution} *) + + type 'r info = + | One of 'r T.wit + | Routes of 'r wit_route list + + type 'a re = { info : 'a info ; cre : Re.re } + + let compile tre = + let _, wit, re = build 1 tre in + let cre = Re.compile re in + { info = One wit ; cre } + + let route l = + let rel, wl = build_route l in + let cre = Re.compile @@ Re.alt rel in + { info = Routes wl ; cre } + + + type 'a error = [ + | `NoMatch of 'a re * string + | `ConverterFailure of exn + ] + + let extract_with_info ~info ~original subs = match info with + | One w -> extract ~original w subs + | Routes wl -> extract_route ~original wl subs + + let[@inline] exec ?pos ?len ({ info ; cre } as tcre) original = + match Re.exec ?pos ?len cre original with + | None -> Result.Error (`NoMatch (tcre, original)) + | Some subs -> + try + Result.Ok (extract_with_info ~info ~original subs) + with exn -> + Result.Error (`ConverterFailure exn) + + let execp ?pos ?len {cre ; _ } original = + Re.test ?pos ?len cre original + + let all_seq ?pos ?len { info ; cre } original = + let seq = Re.all ?pos ?len cre original in + let get_res subs = extract_with_info ~info ~original subs in + Seq.map get_res seq + + let all ?pos ?len tcre original = + try + Result.Ok (Seq.to_list @@ all_seq ?pos ?len tcre original) + with exn -> + Result.Error (`ConverterFailure exn) + + (** Pretty printers *) + + let sexp ppf s fmt = Format.fprintf ppf ("@[<3>(%s@ "^^fmt^^")@]") s + + (* Only in the stdlib since 4.02, so we copy. *) + let rec pp_list pp ppf = function + | [] -> () + | [v] -> pp ppf v + | v :: vs -> + pp ppf v; + Format.pp_print_space ppf (); + pp_list pp ppf vs + + let rec pp + : type a. _ -> a t -> unit + = fun ppf -> let open T in function + | Regexp (re,_) -> sexp ppf "Re" "%a" Re.pp re + | Conv (tre,_) -> sexp ppf "Conv" "%a" pp tre + | Opt tre -> sexp ppf "Opt" "%a" pp tre + | Alt (tre1, tre2) -> sexp ppf "Alt" "%a@ %a" pp tre1 pp tre2 + | Seq (tre1 ,tre2) -> sexp ppf "Seq" "%a@ %a" pp tre1 pp tre2 + | Prefix (tre1, tre2) -> + sexp ppf "Prefix" "%a@ %a" pp tre1 pp tre2 + | Suffix (tre1, tre2) -> + sexp ppf "Suffix" "%a@ %a" pp tre1 pp tre2 + | Rep tre -> sexp ppf "Rep" "%a" pp tre + | Mod (_,tre) -> sexp ppf "Mod" "%a" pp tre + + let rec pp_wit + : type a. _ -> a T.wit -> unit + = fun ppf -> let open T in function + | Lit i -> sexp ppf "Lit" "%i" i + | Conv (tre,_) -> sexp ppf "Conv" "%a" pp_wit tre + | Opt (_, tre) -> sexp ppf "Opt" "%a" pp_wit tre + | Alt (_, tre1, _, tre2) -> sexp ppf "Alt" "%a@ %a" pp_wit tre1 pp_wit tre2 + | Seq (tre1 ,tre2) -> sexp ppf "Seq" "%a@ %a" pp_wit tre1 pp_wit tre2 + | Rep (i, w, re) -> sexp ppf "Rep" "%i@ %a@ %a" i pp_wit w Re.pp_re re + + let pp_wit_route + : type a. _ -> a wit_route -> unit + = fun ppf (WRoute (_,w,_)) -> pp_wit ppf w + + let pp_re ppf = function + | { info = One w; cre } -> + sexp ppf "One" "%a@ %a" Re.pp_re cre pp_wit w + | { info = Routes wl; cre } -> + sexp ppf "Route" "%a@ %a" Re.pp_re cre (pp_list pp_wit_route) wl + + let pp_error ppf : _ error -> unit = function + | `NoMatch (re, s) -> + Format.fprintf ppf "`NoMatch (%a, %s)" pp_re re s + | `ConverterFailure exn -> + Format.pp_print_string ppf @@ Printexc.to_string exn + + module Internal = struct + type idx = Re.Idx.idx + include T + + let to_t x = x + let from_t x = x + + let build = build + let extract = extract + end + +end diff --git a/src/impl.ml b/src/impl.ml new file mode 100644 index 0000000..5382437 --- /dev/null +++ b/src/impl.ml @@ -0,0 +1,17 @@ +module MarkIdx = struct + type idx = Re.Mark.t + let with_mark f i re = + let i, w, re = f i re in + let idx, re = Re.mark re in + i, w, idx, re + let test = Re.Mark.test +end + +module GroupIdx = struct + type idx = int + let with_mark f i re = + let i', w, re = f (i+1) re in + let re = Re.group re in + i', w, i, re + let test = Re.Group.test +end diff --git a/src/sigs.mli b/src/sigs.mli new file mode 100644 index 0000000..1728aaa --- /dev/null +++ b/src/sigs.mli @@ -0,0 +1,40 @@ +module type S = sig + type t + val pp : Format.formatter -> t -> unit + + val whole_string : t -> t + val no_group : t -> t + val group : t -> t + val seq : t list -> t + val alt : t list -> t + val opt : t -> t + val rep : t -> t + + (** Compilation *) + type re + val pp_re : Format.formatter -> re -> unit + val compile : t -> re + + (** Witness *) + type string + val pp_string : Format.formatter -> string -> unit + val witness : t -> string + + (** Matching *) + module Group : sig + type t + val get : t -> int -> string + val offset : t -> int -> int * int + end + + module Idx : sig + type idx + val with_mark : + (int -> 'b -> 'c * 'd * t) -> int -> 'b -> 'c * 'd * idx * t + val test : Group.t -> idx -> bool + end + + val exec : ?pos:int -> ?len:int -> re -> string -> Group.t option + val all : ?pos:int -> ?len:int -> re -> string -> Group.t Seq.t + val test : ?pos:int -> ?len:int -> re -> string -> bool +end diff --git a/src/tyre.ml b/src/tyre.ml index 5ba3477..26bfaa2 100644 --- a/src/tyre.ml +++ b/src/tyre.ml @@ -14,488 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -module Seq = struct - include Seq - - let of_list l = - let rec aux l () = match l with - | [] -> Seq.Nil - | x :: tail -> Seq.Cons (x, aux tail) - in - aux l - let to_rev_list gen = - fold_left (fun acc x -> x :: acc) [] gen - let to_list gen = List.rev (to_rev_list gen) -end - -(** {2 The various types} *) - -module type IDX = sig - type re - type group - type t - val with_mark : - (int -> 'b -> 'c * 'd * re) -> int -> 'b -> 'c * 'd * t * re - val test : group -> t -> bool -end - -module MarkIdx : IDX with type re := Re.t and type group := Re.Group.t = struct - type t = Re.Mark.t - let with_mark f i re = - let i, w, re = f i re in - let idx, re = Re.mark re in - i, w, idx, re - let test = Re.Mark.test -end -module GroupIdx : IDX with type re := Re.t and type group := Re.Group.t = struct - type t = int - let with_mark f i re = - let i', w, re = f (i+1) re in - let re = Re.group re in - i', w, i, re - let test = Re.Group.test -end - -module type S = sig - - type t - val pp : Format.formatter -> t -> unit - - val whole_string : t -> t - val no_group : t -> t - val group : t -> t - val seq : t list -> t - val alt : t list -> t - val opt : t -> t - val rep : t -> t - - (** Compilation *) - type re - val pp_re : Format.formatter -> re -> unit - val compile : t -> re - - (** Witness *) - type string - val pp_string : Format.formatter -> string -> unit - val witness : t -> string - - (** Matching *) - module Group : sig - type t - val get : t -> int -> string - val offset : t -> int -> int * int - end - - val exec : ?pos:int -> ?len:int -> re -> string -> Group.t option - val all : ?pos:int -> ?len:int -> re -> string -> Group.t Seq.t - val test : ?pos:int -> ?len:int -> re -> string -> bool -end - -module Make - (Re : S) - (Idx : IDX with type re := Re.t and type group := Re.Group.t) -= struct - -module T = struct - - type ('a, 'b) conv = { - to_ : 'a -> 'b ; - from_ : 'b -> 'a ; - } - - type 'a raw = - (* We store a compiled regex to efficiently check string when unparsing. *) - | Regexp : Re.t * Re.re Lazy.t -> Re.string raw - | Conv : 'a raw * ('a, 'b) conv -> 'b raw - | Opt : 'a raw -> ('a option) raw - | Alt : 'a raw * 'b raw -> [`Left of 'a | `Right of 'b] raw - | Seq : 'a raw * 'b raw -> ('a * 'b) raw - | Prefix : 'b raw * 'a raw -> 'a raw - | Suffix : 'a raw * 'b raw -> 'a raw - | Rep : 'a raw -> 'a Seq.t raw - | Mod : (Re.t -> Re.t) * 'a raw -> 'a raw - - type _ wit = - | Lit : int -> Re.string wit - | Conv : 'a wit * ('a, 'b) conv -> 'b wit - | Opt : Idx.t * 'a wit -> 'a option wit - | Alt : Idx.t * 'a wit * Idx.t * 'b wit - -> [`Left of 'a | `Right of 'b] wit - | Seq : - 'a wit * 'b wit -> ('a * 'b) wit - | Rep : int * 'a wit * Re.re -> 'a Seq.t wit - -end - -type 'a t = 'a T.raw - -let regex x : _ t = - let re = lazy Re.(compile @@ whole_string @@ no_group x) in - Regexp (x, re) - -(* Converters - - The exception matching of converters is handled by {!Tyre.exec} directly. -*) -let conv to_ from_ x : _ t = - Conv (x, {to_; from_}) - -let seq a b : _ t = Seq (a, b) -let alt a b : _ t = Alt (a, b) - -let prefix x a : _ t = Prefix (x, a) -let suffix a x : _ t = Suffix (a, x) -let opt a : _ t = Opt a - -module Infix = struct - - let (<|>) = alt - let (<&>) = seq - - let ( *>) = prefix - let (<* ) = suffix - -end -include Infix - -let rep x : _ t = Rep x -let rep1 x = x <&> rep x - -(* [modifier] is unsafe in general (for example [modifier Re.group]). - It shouldn't be exposed to the user. -*) -let modifier f re : _ t = Mod (f, re) - -let unit s re = - conv - (fun _ -> ()) - (fun () -> s) - (regex re) - -let list e = - conv Seq.to_list Seq.of_list (rep e) - -let terminated_list ~sep e = list (e <* sep) -let separated_list ~sep e = - let e = opt (e <&> list (sep *> e)) in - let to_ = function None -> [] | Some (h, t) -> (h :: t) - and from_ = function [] -> None | h :: t -> Some (h, t) - in - conv to_ from_ e - - -(** {2 Witness} *) - -(** A witness is a string such that [exec (compile re) (witness re) = true]. - The computation of the witness is deterministic and should result in - a small example. - - It is used in [eval] for the part of the regex that are ignored. -*) - -let rec witnesspp - : type a . Format.formatter -> a t -> unit - = fun ppf tre -> let open T in match tre with - | Regexp (re, _) -> Re.pp_string ppf @@ Re.witness re - | Conv (tre, _) -> witnesspp ppf tre - | Opt _ -> () - | Alt (tre1, _) -> witnesspp ppf tre1 - | Seq (tre1, tre2) -> - witnesspp ppf tre1 ; - witnesspp ppf tre2 - | Prefix (tre1,tre2) -> - witnesspp ppf tre1 ; - witnesspp ppf tre2 - | Suffix (tre1,tre2) -> - witnesspp ppf tre1 ; - witnesspp ppf tre2 - | Rep _ -> () - | Mod (_,tre) -> - witnesspp ppf tre - -(** {2 Evaluation functions} *) - -(** Evaluation is the act of filling the holes. *) - -let pstr = Re.pp_string -let rec pprep f ppf seq = match seq () with - | Seq.Nil -> () - | Cons (x, seq) -> f ppf x ; pprep f ppf seq - -let rec evalpp - : type a . a t -> Format.formatter -> a -> unit - = fun tre ppf -> let open T in match tre with - | Regexp (_, lazy cre) -> begin function v -> - if not @@ Re.test cre v then - invalid_arg @@ - Format.asprintf "Tyre.eval: regexp not respected by \"%a\"." - Re.pp_string v ; - pstr ppf v - end - | Conv (tre, conv) -> fun v -> evalpp tre ppf (conv.from_ v) - | Opt p -> begin function - | None -> () - | Some x -> evalpp p ppf x - end - | Seq (tre1,tre2) -> fun (x1, x2) -> - evalpp tre1 ppf x1 ; - evalpp tre2 ppf x2 ; - | Prefix(tre_l,tre) -> - fun v -> witnesspp ppf tre_l ; evalpp tre ppf v - | Suffix(tre,tre_g) -> - fun v -> evalpp tre ppf v ; witnesspp ppf tre_g - | Alt (treL, treR) -> begin function - | `Left x -> evalpp treL ppf x - | `Right x -> evalpp treR ppf x - end - | Rep tre -> - pprep (evalpp tre) ppf - | Mod (_, tre) -> evalpp tre ppf - -let eval tre = Format.asprintf "%a" (evalpp tre) - -(** {2 matching} *) - -(** {3 Regexp construction} - - In order to record how we constructed the regexp and how to later - extract information, we build a witness containing all the tools we need. - - Each alternative is marked with {!Re.mark}. We store the markid in order - to be able to guess the branch matched. -*) - -let rec build - : type a. int -> a t -> int * a T.wit * Re.t - = let open! Re in let open T in - fun i -> function - | Regexp (re, _) -> - (i+1), Lit i, group @@ no_group re - | Conv (e, conv) -> - let i', w, re = build i e in - i', Conv (w, conv), re - | Opt e -> - let i', w, id, re = Idx.with_mark build i e in - i', Opt (id,w), opt re - | Alt (e1,e2) -> - let i', w1, id1, re1 = Idx.with_mark build i e1 in - let i'', w2, id2, re2 = Idx.with_mark build i' e2 in - i'', Alt (id1, w1, id2, w2), alt [re1 ; re2] - | Prefix (e_ign,e) -> - let i', w, re = build i e in - let _, _, re_ign = build 1 e_ign in - i', w, seq [no_group re_ign ; re] - | Suffix (e,e_ign) -> - let i', w, re = build i e in - let _, _, re_ign = build 1 e_ign in - i', w, seq [re ; no_group re_ign] - | Seq (e1,e2) -> - let i', w1, re1 = build i e1 in - let i'', w2, re2 = build i' e2 in - i'', Seq (w1, w2), seq [re1; re2] - | Rep e -> - let _, w, re = build 1 e in - (i+1), Rep (i,w,Re.compile re), group @@ rep @@ no_group re - | Mod (f, e) -> - let i', w, re = build i e in - i', w, f re - -(** {3 Extraction.} *) - -(** Extracting is just a matter of following the witness. - We just need to take care of counting where we are in the matching groups. - - To avoid copy, we pass around the original string (and we use positions). -*) -let[@specialize] rec extract - : type a. original:Re.string -> a T.wit -> Re.Group.t -> a - = fun ~original rea s -> let open T in match rea with - | Lit i -> Re.Group.get s i - | Conv (w, conv) -> - let v = extract ~original w s in - conv.to_ v - | Opt (id,w) -> - if not @@ Idx.test s id then None - else Some (extract ~original w s) - | Alt (i1,w1,i2,w2) -> - if Idx.test s i1 then - `Left (extract ~original w1 s) - else if Idx.test s i2 then - `Right (extract ~original w2 s) - else - (* If neither matches, it means it's the empty string, we can - default to the left *) - `Left (extract ~original w1 s) - | Seq (e1,e2) -> - let v1 = extract ~original e1 s in - let v2 = extract ~original e2 s in - (v1, v2) - | Rep (i,e,re) -> extract_list ~original e re i s - -(** We need to re-match the string for lists, in order to extract - all the elements. - Re doesn't offer the possibility to keep the results when - grouping under a star (one could argue it's theoretically not - possible as it would be equivalent to counting in an automaton). -*) -and[@specialize] extract_list - : type a. original:Re.string -> a T.wit -> Re.re -> int -> Re.Group.t -> a Seq.t - = fun ~original e re i s -> - let aux = extract ~original e in - let (pos, pos') = Re.Group.offset s i in - let len = pos' - pos in - Seq.map aux @@ Re.all ~pos ~len re original - -(** {4 Multiple match} *) - -type +'r route = Route : 'a t * ('a -> 'r) -> 'r route - -let route re f = Route (re, f) - -let (-->) = route - -type 'r wit_route = - WRoute : Idx.t * 'a T.wit * ('a -> 'r) -> 'r wit_route - -(* It's important to keep the order here, since Re will choose - the first regexp if there is ambiguity. -*) -let rec build_route_aux i rel wl = function - | [] -> List.rev rel, List.rev wl - | Route (tre, f) :: l -> - let i', wit, id, re = Idx.with_mark build i tre in - let w = WRoute (id, wit, f) in - build_route_aux i' (re::rel) (w::wl) l - -let build_route l = build_route_aux 1 [] [] l - -let rec extract_route ~original wl subs = match wl with - | [] -> - (* Invariant: At least one of the regexp of the alternative matches. *) - assert false - | WRoute (id, wit, f) :: wl -> - if Idx.test subs id then - f (extract ~original wit subs) - else - extract_route ~original wl subs - -(** {4 Compilation and execution} *) - -type 'r info = - | One of 'r T.wit - | Routes of 'r wit_route list - -type 'a re = { info : 'a info ; cre : Re.re } - -let compile tre = - let _, wit, re = build 1 tre in - let cre = Re.compile re in - { info = One wit ; cre } - -let route l = - let rel, wl = build_route l in - let cre = Re.compile @@ Re.alt rel in - { info = Routes wl ; cre } - - -type 'a error = [ - | `NoMatch of 'a re * string - | `ConverterFailure of exn -] - -let extract_with_info ~info ~original subs = match info with - | One w -> extract ~original w subs - | Routes wl -> extract_route ~original wl subs - -let[@inline] exec ?pos ?len ({ info ; cre } as tcre) original = - match Re.exec ?pos ?len cre original with - | None -> Result.Error (`NoMatch (tcre, original)) - | Some subs -> - try - Result.Ok (extract_with_info ~info ~original subs) - with exn -> - Result.Error (`ConverterFailure exn) - -let execp ?pos ?len {cre ; _ } original = - Re.test ?pos ?len cre original - -let all_seq ?pos ?len { info ; cre } original = - let seq = Re.all ?pos ?len cre original in - let get_res subs = extract_with_info ~info ~original subs in - Seq.map get_res seq - -let all ?pos ?len tcre original = - try - Result.Ok (Seq.to_list @@ all_seq ?pos ?len tcre original) - with exn -> - Result.Error (`ConverterFailure exn) - -(** Pretty printers *) - -let sexp ppf s fmt = Format.fprintf ppf ("@[<3>(%s@ "^^fmt^^")@]") s - -(* Only in the stdlib since 4.02, so we copy. *) -let rec pp_list pp ppf = function - | [] -> () - | [v] -> pp ppf v - | v :: vs -> - pp ppf v; - Format.pp_print_space ppf (); - pp_list pp ppf vs - -let rec pp - : type a. _ -> a t -> unit - = fun ppf -> let open T in function - | Regexp (re,_) -> sexp ppf "Re" "%a" Re.pp re - | Conv (tre,_) -> sexp ppf "Conv" "%a" pp tre - | Opt tre -> sexp ppf "Opt" "%a" pp tre - | Alt (tre1, tre2) -> sexp ppf "Alt" "%a@ %a" pp tre1 pp tre2 - | Seq (tre1 ,tre2) -> sexp ppf "Seq" "%a@ %a" pp tre1 pp tre2 - | Prefix (tre1, tre2) -> - sexp ppf "Prefix" "%a@ %a" pp tre1 pp tre2 - | Suffix (tre1, tre2) -> - sexp ppf "Suffix" "%a@ %a" pp tre1 pp tre2 - | Rep tre -> sexp ppf "Rep" "%a" pp tre - | Mod (_,tre) -> sexp ppf "Mod" "%a" pp tre - -let rec pp_wit - : type a. _ -> a T.wit -> unit - = fun ppf -> let open T in function - | Lit i -> sexp ppf "Lit" "%i" i - | Conv (tre,_) -> sexp ppf "Conv" "%a" pp_wit tre - | Opt (_, tre) -> sexp ppf "Opt" "%a" pp_wit tre - | Alt (_, tre1, _, tre2) -> sexp ppf "Alt" "%a@ %a" pp_wit tre1 pp_wit tre2 - | Seq (tre1 ,tre2) -> sexp ppf "Seq" "%a@ %a" pp_wit tre1 pp_wit tre2 - | Rep (i, w, re) -> sexp ppf "Rep" "%i@ %a@ %a" i pp_wit w Re.pp_re re - -let pp_wit_route - : type a. _ -> a wit_route -> unit - = fun ppf (WRoute (_,w,_)) -> pp_wit ppf w - -let pp_re ppf = function - | { info = One w; cre } -> - sexp ppf "One" "%a@ %a" Re.pp_re cre pp_wit w - | { info = Routes wl; cre } -> - sexp ppf "Route" "%a@ %a" Re.pp_re cre (pp_list pp_wit_route) wl - -let pp_error ppf : _ error -> unit = function - | `NoMatch (re, s) -> - Format.fprintf ppf "`NoMatch (%a, %s)" pp_re re s - | `ConverterFailure exn -> - Format.pp_print_string ppf @@ Printexc.to_string exn - -module Internal = struct - type idx = Idx.t - include T - - let to_t x = x - let from_t x = x - - let build = build - let extract = extract -end - -end +open Tyrefun include Make(struct include Re @@ -506,7 +25,9 @@ include Make(struct let exec = exec_opt let all = Seq.all let test = execp - end)(MarkIdx) + + module Idx = Impl.MarkIdx + end) let pcre s = regex @@ Re.Pcre.re s diff --git a/src/tyrefun.ml b/src/tyrefun.ml new file mode 100644 index 0000000..d34f98f --- /dev/null +++ b/src/tyrefun.ml @@ -0,0 +1,4 @@ +include Core + +module type S = Sigs.S +module Make = Functor.Make