From d83e1f758478eb0168ab3c83eff3e7d5bcd3c8c9 Mon Sep 17 00:00:00 2001 From: Drup Date: Thu, 18 Oct 2018 14:34:18 +0200 Subject: [PATCH 1/3] 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/3] 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/3] 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