diff --git a/src/tyre.ml b/src/tyre.ml index 80ec3ca..a2debad 100644 --- a/src/tyre.ml +++ b/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 -> diff --git a/src/tyre.mli b/src/tyre.mli index d989764..1a392ee 100644 --- a/src/tyre.mli +++ b/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 diff --git a/test/test.ml b/test/test.ml index 4979fad..99cb8da 100644 --- a/test/test.ml +++ b/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)