Introduce matched_string

src/tyre.ml

@@ -52,6 +52,7 @@ module T = struct
     | Suffix : ('e, 'a) raw * (_, 'b) raw -> ('e, 'a) raw
     | Rep : ('e, 'a) raw -> ('e, 'a Seq.t) raw
     | Mod : (Re.t -> Re.t) * ('e, 'a) raw -> ('e, 'a) raw
+    | Matched_string : (_, 'a) raw -> ('e, string) raw
 
   type _ wit =
     | Lit : int -> string wit
@@ -80,6 +81,9 @@ let pcre s = regex @@ Re.Pcre.re s
 
    The exception matching of converters is handled by {!Tyre.exec} directly.
 *)
+
+let matched_string t : string pattern = Matched_string t
+
 let conv to_ from_ x : _ t = Conv (x, {to_; from_})
 
 let map f x : _ t = Map (x, f)
@@ -336,6 +340,8 @@ let rec witnesspp : type e a. Format.formatter -> (e, a) t -> unit =
       ()
   | Mod (_, tre) ->
       witnesspp ppf tre
+  | Matched_string tre ->
+      witnesspp ppf tre
 
 (** {2 Evaluation functions} *)
 
@@ -380,6 +386,8 @@ let rec evalpp : type a. a expression -> Format.formatter -> a -> unit =
       invalid_arg "Alt is not compatible with eval. This should never happen."
   | Map _ ->
       invalid_arg "Map is not compatible with eval. This should never happen."
+  | Matched_string _ ->
+      invalid_arg "Matched_string is not compatible with eval. This should never happen."
 
 let eval tre = Format.asprintf "%a" (evalpp tre)
 
@@ -394,6 +402,7 @@ let eval tre = Format.asprintf "%a" (evalpp tre)
     to be able to guess the branch matched.
 *)
 
+(** {3 Extraction.} *)
 let rec build : type e a. int -> (e, a) t -> int * a T.wit * Re.t =
   let open! Re in
   let open T in
@@ -435,8 +444,9 @@ let rec build : type e a. int -> (e, a) t -> int * a T.wit * Re.t =
     | Mod (f, e) ->
         let i', w, re = build i e in
         (i', w, f re)
-
-(** {3 Extraction.} *)
+    | Matched_string e ->
+        let _, _, re = build i e in
+        (i + 1, Lit i, group @@ no_group re)
 
 (** Extracting is just a matter of following the witness.
     We just need to take care of counting where we are in the matching groups.
@@ -614,6 +624,8 @@ let rec pp : type e a. _ -> (e, a) t -> unit =
       sexp ppf "Rep" "%a" pp tre
   | Mod (_, tre) ->
       sexp ppf "Mod" "%a" pp tre
+  | tre ->
+      sexp ppf "Matched_string" "%a" pp tre
 
 let rec pp_wit : type a. _ -> a T.wit -> unit =
  fun ppf ->

src/tyre.mli

@@ -71,6 +71,14 @@ val regex : Re.t -> (_, string) t
     Groups inside [re] are erased.
 *)
 
+val matched_string : (_, 'a) t -> string pattern
+(** [matched_string t] matches the same string as [t], but return the matched
+    texted, discarding the result computed by [t].
+
+  Does not support [eval] because it not possible to implement for
+  [matched_string (prefix ...)].
+  *)
+
 val conv : ('a -> 'b) -> ('b -> 'a) -> ('e, 'a) t -> ('e, 'b) t
 (** [conv to_ from_ tyre] matches the same text as [tyre], but converts back and forth to a different data type.
 
@@ -135,11 +143,11 @@ val rep1 : ('e, 'a) t -> ('e, 'a * 'a Seq.t) t
 val seq : ('e, 'a) t -> ('e, 'b) t -> ('e, 'a * 'b) t
 (** [seq tyre1 tyre2] matches [tyre1] then [tyre2] and return both values. *)
 
-val prefix : ('e, _) t -> ('e, 'a) t -> ('e, 'a) t
+val prefix : (_, _) t -> ('e, 'a) t -> ('e, 'a) t
 (** [prefix tyre_i tyre] matches [tyre_i], ignores the result, and then matches [tyre] and returns its result. Converters in [tyre_i] are never called.
 *)
 
-val suffix : ('e, 'a) t -> ('e, _) t -> ('e, 'a) t
+val suffix : ('e, 'a) t -> (_, _) t -> ('e, 'a) t
 (** Same as [prefix], but reversed. *)
 
 (** {2 Let operators}*)
@@ -166,10 +174,10 @@ val ( <|> ) : (_, 'a) t -> (_, 'a) t -> 'a pattern
 val ( <&> ) : ('e, 'a) t -> ('e, 'b) t -> ('e, 'a * 'b) t
 (** [t <&> t'] is [seq t t']. *)
 
-val ( *> ) : ('e, _) t -> ('e, 'a) t -> ('e, 'a) t
+val ( *> ) : (_, _) t -> ('e, 'a) t -> ('e, 'a) t
 (** [ ti *> t ] is [prefix ti t]. *)
 
-val ( <* ) : ('e, 'a) t -> ('e, _) t -> ('e, 'a) t
+val ( <* ) : ('e, 'a) t -> (_, _) t -> ('e, 'a) t
 (** [ t <* ti ] is [suffix t ti]. *)
 
 module Infix : sig
@@ -183,10 +191,10 @@ module Infix : sig
   val ( <&> ) : ('e, 'a) t -> ('e, 'b) t -> ('e, 'a * 'b) t
   (** [t <&> t'] is [seq t t']. *)
 
-  val ( *> ) : ('e, _) t -> ('e, 'a) t -> ('e, 'a) t
+  val ( *> ) : (_, _) t -> ('e, 'a) t -> ('e, 'a) t
   (** [ ti *> t ] is [prefix ti t]. *)
 
-  val ( <* ) : ('e, 'a) t -> ('e, _) t -> ('e, 'a) t
+  val ( <* ) : ('e, 'a) t -> (_, _) t -> ('e, 'a) t
   (** [ t <* ti ] is [suffix t ti]. *)
 
   val ( <*> ) : ('e, 'a -> 'b) t -> ('e, 'a) t -> 'b pattern
@@ -507,6 +515,7 @@ module Internal : sig
     | Suffix : ('e, 'a) raw * (_, 'b) raw -> ('e, 'a) raw
     | Rep : ('e, 'a) raw -> ('e, 'a Seq.t) raw
     | Mod : (Re.t -> Re.t) * ('e, 'a) raw -> ('e, 'a) raw
+    | Matched_string : (_, 'a) raw -> ('e, string) raw
 
   val from_t : ('e, 'a) t -> ('e, 'a) raw
 

test/test.ml

@@ -157,6 +157,12 @@ let prefix_suffix =
       (str "foo" *> bool <&> int)
       (true, 4) "footrue4" ]
 
+let matched_string =
+  [ t_pat "int" A.string (matched_string int) "33" "33"
+  ; t_pat "prefix suffix" A.string
+      (str "abc" *> matched_string (bool <* int) <* bool)
+      "false33" "abcfalse33true" ]
+
 let composed =
   [ topt "option prefix" A.int (opt int <* str "foo") 3 "3foo" "foo"
   ; t "terminated list"
@@ -256,6 +262,7 @@ let () =
     ; ("charset", charset)
     ; ("not whole", notwhole)
     ; ("prefix suffix", prefix_suffix)
+    ; ("matched_string", matched_string)
     ; ("composed", composed)
     ; ("marks", marks)
     ; ("routes", route_test)