Skip to content

Commit 0e3b113

Browse files
zazeddzazedd
authored
type ... = {%mikmatch| ... |} extension (#7)
* transform type syntax extension * tests and improvements * more parsing+printing tests
1 parent 433c33d commit 0e3b113

File tree

7 files changed

+455
-30
lines changed

7 files changed

+455
-30
lines changed

‎lib/mik_parser.mly‎

Lines changed: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -102,6 +102,7 @@ pattern:
102102
| alt_expr { $1 }
103103
| alt_expr PIPE func = ident AS name = IDENT {
104104
let name_loc = wrap_loc $startpos(name) $endpos(name) name in
105+
let func = string_to_longident func in
105106
wrap_loc $startpos $endpos (Pipe_all (name_loc, func, $1))
106107
}
107108
| alt_expr PIPE { missing_error "function name after '>>>'" $startpos($2) $endpos }
@@ -244,7 +245,18 @@ basic_atom:
244245
let call_loc = wrap_loc $startpos(id) $endpos(id) (string_to_longident id) in
245246
let call_node = wrap_loc $startpos(id) $endpos(id) (Call call_loc) in
246247
let name_loc = wrap_loc $startpos(name) $endpos(name) name in
247-
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func func), call_node))
248+
let func = string_to_longident func in
249+
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func (func, None)), call_node))
250+
}
251+
| LPAREN id = IDENT AS name = IDENT COLON EQUAL func = ident COLON typ = ident RPAREN
252+
| LPAREN id = MOD_IDENT AS name = IDENT COLON EQUAL func = ident COLON typ = ident RPAREN {
253+
(* (text as t := process : typ) -> captures 'text' pattern as 't' processed by function, with result as type 'typ' *)
254+
let call_loc = wrap_loc $startpos(id) $endpos(id) (string_to_longident id) in
255+
let call_node = wrap_loc $startpos(id) $endpos(id) (Call call_loc) in
256+
let name_loc = wrap_loc $startpos(name) $endpos(name) name in
257+
let func = string_to_longident func in
258+
let typ = string_to_longident typ in
259+
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func (func, Some typ)), call_node))
248260
}
249261
| LPAREN IDENT AS IDENT EOF?
250262
| LPAREN MOD_IDENT AS IDENT EOF? {
@@ -286,7 +298,14 @@ basic_atom:
286298
}
287299
| LPAREN pattern AS name = IDENT COLON EQUAL func = ident RPAREN {
288300
let name_loc = wrap_loc $startpos(name) $endpos(name) name in
289-
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func func), $2))
301+
let func = string_to_longident func in
302+
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func (func, None)), $2))
303+
}
304+
| LPAREN pattern AS name = IDENT COLON EQUAL func = ident COLON typ = ident RPAREN {
305+
let name_loc = wrap_loc $startpos(name) $endpos(name) name in
306+
let func = string_to_longident func in
307+
let typ = string_to_longident typ in
308+
wrap_loc $startpos $endpos (Capture_as (name_loc, Some (Func (func, Some typ)), $2))
290309
}
291310
| LPAREN pattern AS IDENT EOF? {
292311
unclosed_error "parentheses (missing ')')" $startpos($1) $endpos($4)

‎lib/regexp_types.ml‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,15 +15,15 @@ and 'a node =
1515
| Caseless of 'a t
1616
| Capture of 'a t
1717
| Capture_as of string Location.loc * conv_ty option * 'a t
18-
| Pipe_all of string Location.loc * string * 'a t
18+
| Pipe_all of string Location.loc * Longident.t * 'a t
1919
| Call of Longident.t Location.loc
2020
(* TODO: | Case_blind of t *)
2121

2222
and conv_ty =
2323
| Int
2424
| Float
25-
| Func of string
26-
| Pipe_all_func of string
25+
| Func of (Longident.t * Longident.t option) (* function name * type *)
26+
| Pipe_all_func of Longident.t
2727

2828
type flags = {
2929
case_insensitive : bool; (* i *)

‎lib/regexp_types.mli‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -15,15 +15,15 @@ and 'a node =
1515
| Caseless of 'a t
1616
| Capture of 'a t
1717
| Capture_as of string Location.loc * conv_ty option * 'a t
18-
| Pipe_all of string Location.loc * string * 'a t
18+
| Pipe_all of string Location.loc * Longident.t * 'a t
1919
| Call of Longident.t Location.loc
2020
(* TODO: | Case_blind of t *)
2121

2222
and conv_ty =
2323
| Int
2424
| Float
25-
| Func of string
26-
| Pipe_all_func of string
25+
| Func of (Longident.t * Longident.t option) (* function name * type *)
26+
| Pipe_all_func of Longident.t
2727

2828
type flags = {
2929
case_insensitive : bool; (* i *)

‎ppx_regexp/ppx_regexp.ml‎

Lines changed: 53 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -34,25 +34,64 @@ let transformation =
3434

3535
method! structure_item item acc =
3636
match item.pstr_desc with
37+
| Pstr_type (rec_flag, type_decls) ->
38+
let needs_transformation =
39+
List.exists
40+
(fun td ->
41+
match td.ptype_manifest with
42+
| Some { ptyp_desc = Ptyp_extension ({ txt = "pcre" | "mikmatch"; _ }, _); _ } -> true
43+
| _ -> false)
44+
type_decls
45+
in
46+
47+
if not needs_transformation then super#structure_item item acc
48+
else (
49+
let all_items =
50+
List.fold_left
51+
(fun items_acc td ->
52+
match td.ptype_manifest with
53+
(* type ... = {%mikmatch| ... |} *)
54+
| Some
55+
{
56+
ptyp_desc =
57+
Ptyp_extension
58+
( { txt = ("pcre" | "mikmatch") as ext; loc },
59+
PStr [ { pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (pattern_str, _, _)); _ }, _); _ } ]
60+
);
61+
_;
62+
} ->
63+
let mode = if ext = "pcre" then `Pcre else `Mik in
64+
let type_name = td.ptype_name.txt in
65+
let bindings = Transformations.transform_type ~mode ~loc rec_flag type_name pattern_str td in
66+
items_acc @ bindings
67+
| _ -> items_acc)
68+
[] type_decls
69+
in
70+
71+
let wrapped = pstr_include ~loc:item.pstr_loc (include_infos ~loc:item.pstr_loc (pmod_structure ~loc:item.pstr_loc all_items)) in
72+
73+
wrapped, acc)
3774
(* let%mik/%pcre x = {|some regex|}*)
3875
| Pstr_extension (({ txt = ("pcre" | "mikmatch") as ext; _ }, PStr [ { pstr_desc = Pstr_value (rec_flag, vbs); _ } ]), _) ->
3976
let mode = if ext = "pcre" then `Pcre else `Mik in
4077
let processed_vbs, collected_bindings =
4178
List.fold_left
42-
(fun (vbs_acc, bindings_acc) vb ->
43-
match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with
44-
(* pattern definition - let%mikmatch/%pcre name = {|/regex/|} *)
45-
| Ppat_var { txt = var_name; loc }, Pexp_constant (Pconst_string (_, _, _)) ->
46-
let binding = Transformations.transform_let ~mode vb in
47-
let alias = make_alias_binding ~loc ~var_name in
48-
alias :: vbs_acc, binding :: bindings_acc
49-
(* destructuring - let%mikmatch {|/pattern/|} = expr *)
50-
| Ppat_constant (Pconst_string (pattern_str, _, _)), _ ->
51-
let new_vb, new_bindings = Transformations.transform_destructuring_let ~mode ~loc:vb.pvb_loc pattern_str vb.pvb_expr in
52-
new_vb :: vbs_acc, new_bindings @ bindings_acc
53-
| _ ->
54-
let binding = Transformations.transform_let ~mode vb in
55-
binding :: vbs_acc, binding :: bindings_acc)
79+
begin
80+
fun (vbs_acc, bindings_acc) vb ->
81+
match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with
82+
(* pattern definition - let%mikmatch/%pcre name = {|/regex/|} *)
83+
| Ppat_var { txt = var_name; loc }, Pexp_constant (Pconst_string (_, _, _)) ->
84+
let binding = Transformations.transform_let ~mode vb in
85+
let alias = make_alias_binding ~loc ~var_name in
86+
alias :: vbs_acc, binding :: bindings_acc
87+
(* destructuring - let%mikmatch {|/pattern/|} = expr *)
88+
| Ppat_constant (Pconst_string (pattern_str, _, _)), _ ->
89+
let new_vb, new_bindings = Transformations.transform_destructuring_let ~mode ~loc:vb.pvb_loc pattern_str vb.pvb_expr in
90+
new_vb :: vbs_acc, new_bindings @ bindings_acc
91+
| _ ->
92+
let binding = Transformations.transform_let ~mode vb in
93+
binding :: vbs_acc, binding :: bindings_acc
94+
end
5695
([], acc) vbs
5796
in
5897

0 commit comments

Comments
 (0)