Support binding group 0 and universal patterns.

Author: paurkedal

README.md

@@ -11,11 +11,19 @@ match%pcre x with
 ```
 into suitable invocations of the
 [Re library](https://github.com/ocaml/ocaml-re).  The patterns are plain
-strings of the form accepted by `Re_pcre`, except groups can be bound to
-variables using the syntax `(?<var>...)`.  The type of `var` will be
-`string` if a match is of the groups is guaranteed given a match of the
-whole pattern, and `string option` if the variable is bound to or nested
-below an optionally matched group.
+strings of the form accepted by `Re_pcre`, with the following additions:
+
+  - `(?<var>...)` defines a group and binds whatever it matches as `var`.
+    The type of `var` will be `string` if the match is guaranteed given that
+    the whole pattern matches, and `string option` if the variable is bound
+    to or nested below an optionally matched group.
+
+  - `?<var>` at the start of a pattern binds group 0 as `var : string`.
+    This may not be the full string if the pattern is unanchored.
+
+A variable is allowed for the universal case and is bound to the matched
+string.  A regular alias is currently not allowed for patterns, since it is
+not obvious whether is should bind the full string or group 0.
 
 ## Example
 

ppx_regexp.ml

@@ -89,7 +89,7 @@ let extract_bindings ~loc p =
         (match stack with
          | [] -> error ~loc "Unmached end of group."
          | ((Some varG, iG, bs') :: stack') ->
-            let bs = (varG, iG, true) :: bs in
+            let bs = (varG, Some iG, true) :: bs in
             (bs, bs', stack')
          | ((None, _, bs') :: stack') ->
             (bs, bs', stack'))
@@ -100,30 +100,53 @@ let extract_bindings ~loc p =
       in
       parse_normal nG stack' (List.rev_append bs bs') i
   in
-  let bs, nG = parse_normal 0 [] [] 0 in
-  (Buffer.contents buf, bs, nG)
+  let parse_first () =
+    if l >= 4 && p.[0] = '?' && p.[1] = '<' then
+      let j = String.index_from p 2 '>' in
+      let varG = String.sub p 2 (j - 2) in
+      parse_normal 0 [] [varG, None, true] (j + 1)
+    else
+      parse_normal 0 [] [] 0
+  in
+  let bs, nG = parse_first () in
+  let re_str = Buffer.contents buf in
+  (try ignore (Re_pcre.regexp re_str) with
+   | Re_perl.Not_supported -> error ~loc "Unsupported regular expression."
+   | Re_perl.Parse_error -> error ~loc "Invalid regular expression.");
+  (Exp.constant (Const.string re_str), bs, nG)
 
-let transform_cases ~loc e cases =
+let transform_cases ~loc cases =
   let aux case =
     if case.pc_guard <> None then
       error ~loc "Guards are not implemented for match%pcre." else
     (match case.pc_lhs with
      | { ppat_desc = Ppat_constant (Pconst_string (re_src,_));
          ppat_loc = loc; _ } ->
-        let re_str, bs, nG = extract_bindings ~loc re_src in
-        (try ignore (Re_pcre.regexp re_str) with
-         | Re_perl.Not_supported -> error ~loc "Unsupported regular expression."
-         | Re_perl.Parse_error -> error ~loc "Invalid regular expression.");
-        (Exp.constant (Const.string re_str), nG, bs, case.pc_rhs)
+        let re, bs, nG = extract_bindings ~loc re_src in
+        (re, nG, bs, case.pc_rhs)
+(*
+     | {ppat_desc = Ppat_alias
+         ({ ppat_desc = Ppat_constant (Pconst_string (re_src,_));
+            ppat_loc = loc; _ },
+          var); _} ->
+        let re, bs, nG = extract_bindings ~loc re_src in
+        let rhs =
+          (* TODO: Should this be (_ppx_regexp_v or Re.Group.get _g 0? *)
+          [%expr let [%p Pat.var var] = _ppx_regexp_v in [%e case.pc_rhs]] in
+        (re, nG, bs, rhs)
+*)
      | {ppat_desc = Ppat_any; _} ->
         error ~loc "Universal wildcard must be the last pattern."
      | {ppat_loc = loc; _} ->
         error ~loc "Regular expression pattern should be a string.")
   in
   let cases, default_rhs =
     (match List.rev cases with
-     | {pc_lhs = {ppat_desc = Ppat_any; _}; pc_rhs; _} :: cases ->
+     | {pc_lhs = {ppat_desc = Ppat_any; _}; pc_rhs; pc_guard = None} :: cases ->
         (cases, pc_rhs)
+     | {pc_lhs = {ppat_desc = Ppat_var var; _}; pc_rhs; pc_guard = None} ::
+       cases ->
+        (cases, [%expr let [%p Pat.var var] = _ppx_regexp_v in [%e pc_rhs]])
      | cases ->
         let open Lexing in
         let pos = loc.Location.loc_start in
@@ -148,8 +171,11 @@ let transform_cases ~loc e cases =
   let rec wrap_groups rhs offG = function
    | [] -> rhs
    | (varG, iG, mustG) :: bs ->
-      let eG =
-        [%expr Re.Group.get _g [%e Exp.constant (Const.int (offG + iG + 1))]]
+      let eG = match iG with
+       | None ->
+          [%expr Re.Group.get _g 0]
+       | Some iG ->
+          [%expr Re.Group.get _g [%e Exp.constant (Const.int (offG + iG + 1))]]
       in
       let eG =
         if mustG then eG else
@@ -170,7 +196,7 @@ let transform_cases ~loc e cases =
           [%e handle_cases (i + 1) (offG + nG) cases]]
   in
   [%expr
-    (match Re.exec_opt (fst [%e e_comp]) [%e e] with
+    (match Re.exec_opt (fst [%e e_comp]) _ppx_regexp_v with
      | None -> [%e default_rhs]
      | Some _g -> [%e handle_cases 0 0 cases])]
 
@@ -181,9 +207,9 @@ let rewrite_expr mapper e_ext =
       let loc = e.pexp_loc in
       (match e.pexp_desc with
        | Pexp_match (e, cases) ->
-          transform_cases ~loc e cases
+          [%expr let _ppx_regexp_v = [%e e] in [%e transform_cases ~loc cases]]
        | Pexp_function (cases) ->
-          [%expr fun _s -> [%e transform_cases ~loc [%expr _s] cases]]
+          [%expr fun _ppx_regexp_v -> [%e transform_cases ~loc cases]]
        | _ ->
           error ~loc "[%pcre] only applies to match an function.")
    | _ -> default_mapper.expr mapper e_ext)

test_ppx_regexp.ml

@@ -44,6 +44,15 @@ let rec test2 s =
    | {|^[^{}]*\{(?<s'>.*)\}|} -> test2 s'
    | _ -> assert false)
 
+let test3 s =
+  (match%pcre s with
+   | {|no(is)((e)) (?<is>is) (g(oo)d)|} -> assert (is = "is")
+   | {|?<s'>&()[a-zA-Z0-9_-]+(;)|} ->
+      let i, j = String.index s '&', String.rindex s ';' in
+      assert (s' = String.sub s i (j - i + 1))
+   | {|m(o+)re re(gular)? no(is)e, (no )*be(t+)?er|} -> ()
+   | s' -> assert (s = s'))
+
 let () =
   test2 "<>";
   test2 "<a>";
@@ -53,7 +62,9 @@ let () =
   test2 "a;";
   test2 "a;b;c;d;";
   test2 "<a;b>";
-  test2 "Xx{--{a;b;c;}--}yY."
+  test2 "Xx{--{a;b;c;}--}yY.";
+  test3 "- + &nbsp; + -";
+  test3 "catch-all"
 
 (* It should work in a functor, and Re_pcre.regxp should be lifted to the
  * top-level. *)
@@ -67,6 +78,6 @@ end
 (* It should work as a top-level eval. *)
 let r = ref false
 ;;(match%pcre "" with
-   | "$^" -> r := true
+   | {|^$|} -> r := true
    | _ -> assert false)
 ;;assert (!r = true)