Skip to content

Commit bb907f0

Browse files
tatchitatchi
committed
merge extractors
1 parent 4ebeb19 commit bb907f0

File tree

3 files changed

+57
-80
lines changed

3 files changed

+57
-80
lines changed

‎src/ppx_import.ml

Lines changed: 54 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -648,89 +648,70 @@ let module_declaration_expand_intf ~ctxt modtype_decl =
648648
in
649649
Ppxlib.{psig_desc = Psig_modtype md_decl; psig_loc = loc}
650650

651-
let type_declaration_expander ~ctxt payload =
652-
let return_error e =
653-
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
654-
let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in
655-
Ppxlib.Ast_builder.Default.pstr_extension ext [] ~loc
656-
in
651+
type extracted_payload =
652+
| Type_decl of Asttypes.rec_flag * Parsetree.type_declaration list
653+
| Module_type_decl of Parsetree.module_type_declaration
654+
655+
let type_extractor =
656+
Ppxlib.Ast_pattern.(
657+
pstr (pstr_type __ __ ^:: nil)
658+
||| psig (psig_type __ __ ^:: nil)
659+
|> map2 ~f:(fun rec_flag type_decl -> Type_decl (rec_flag, type_decl)) )
660+
661+
let module_type_extractor =
662+
Ppxlib.Ast_pattern.(
663+
psig (psig_modtype __ ^:: nil)
664+
||| pstr (pstr_modtype __ ^:: nil)
665+
|> map1 ~f:(fun modtype -> Module_type_decl modtype) )
666+
667+
let extractor = Ppxlib.Ast_pattern.(type_extractor ||| module_type_extractor)
668+
669+
let expander ~(ctxt : Ppxlib.Expansion_context.Extension.t)
670+
(payload : extracted_payload) =
657671
match payload with
658-
| Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}]
659-
|Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] ->
672+
| Type_decl (rec_flag, type_decls) ->
660673
type_declaration_expand ~ctxt rec_flag type_decls
661-
| Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}]
662-
|Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] ->
674+
| Module_type_decl modtype_decl ->
663675
module_declaration_expand ~ctxt modtype_decl
664-
| Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] ->
665-
return_error
666-
"[%%import] Expected a type declaration or a module type declaration"
667-
| Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) ->
668-
return_error
669-
"[%%import] Expected exactly one item in the structure or signature, but \
670-
found multiple items"
671-
| Parsetree.PStr [] | Parsetree.PSig [] ->
672-
return_error
673-
"[%%import] Expected exactly one item in the structure or signature, but \
674-
found none"
675-
| Parsetree.PTyp _ ->
676-
return_error
677-
"[%%import] Type pattern (PTyp) is not supported, only type and module \
678-
type declarations are allowed"
679-
| Parsetree.PPat (_, _) ->
680-
return_error
681-
"[%%import] Pattern (PPat) is not supported, only type and module type \
682-
declarations are allowed"
683-
684-
let type_declaration_extension =
676+
677+
let import_extension =
685678
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item
686-
Ppxlib.Ast_pattern.(__)
687-
type_declaration_expander
688-
689-
let type_declaration_expander_intf ~ctxt payload =
690-
let return_error e =
691-
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
692-
let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in
693-
Ppxlib.Ast_builder.Default.psig_extension ext [] ~loc
694-
in
679+
extractor expander
680+
681+
let import_declaration_rule =
682+
Ppxlib.Context_free.Rule.extension import_extension
683+
684+
let type_extractor_intf =
685+
Ppxlib.Ast_pattern.(
686+
pstr (pstr_type __ __ ^:: nil)
687+
||| psig (psig_type __ __ ^:: nil)
688+
|> map2 ~f:(fun rec_flag type_decl -> Type_decl (rec_flag, type_decl)) )
689+
690+
let module_type_extractor_intf =
691+
Ppxlib.Ast_pattern.(
692+
psig (psig_modtype __ ^:: nil)
693+
||| pstr (pstr_modtype __ ^:: nil)
694+
|> map1 ~f:(fun modtype -> Module_type_decl modtype) )
695+
696+
let extractor_intf =
697+
Ppxlib.Ast_pattern.(type_extractor_intf ||| module_type_extractor_intf)
698+
699+
let expander_intf ~(ctxt : Ppxlib.Expansion_context.Extension.t)
700+
(payload : extracted_payload) =
695701
match payload with
696-
| Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}]
697-
|Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] ->
702+
| Type_decl (rec_flag, type_decls) ->
698703
type_declaration_expand_intf ~ctxt rec_flag type_decls
699-
| Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}]
700-
|Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] ->
704+
| Module_type_decl modtype_decl ->
701705
module_declaration_expand_intf ~ctxt modtype_decl
702-
| Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] ->
703-
return_error
704-
"[%%import] Expected a type declaration or a module type declaration"
705-
| Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) ->
706-
return_error
707-
"[%%import] Expected exactly one item in the structure or signature, but \
708-
found multiple items"
709-
| Parsetree.PStr [] | Parsetree.PSig [] ->
710-
return_error
711-
"[%%import] Expected exactly one item in the structure or signature, but \
712-
found none"
713-
| Parsetree.PTyp _ ->
714-
return_error
715-
"[%%import] Type pattern (PTyp) is not supported, only type and module \
716-
type declarations are allowed"
717-
| Parsetree.PPat (_, _) ->
718-
return_error
719-
"[%%import] Pattern (PPat) is not supported, only type and module type \
720-
declarations are allowed"
721-
722-
let type_declaration_extension_intf =
723-
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item
724-
Ppxlib.Ast_pattern.(__)
725-
type_declaration_expander_intf
726706

727-
let type_declaration_rule =
728-
Ppxlib.Context_free.Rule.extension type_declaration_extension
707+
let import_extension_intf =
708+
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item
709+
extractor_intf expander_intf
729710

730-
let type_declaration_rule_intf =
731-
Ppxlib.Context_free.Rule.extension type_declaration_extension_intf
711+
let import_declaration_rule_intf =
712+
Ppxlib.Context_free.Rule.extension import_extension_intf
732713

733714
let () =
734715
Ppxlib.Driver.V2.register_transformation
735-
~rules:[type_declaration_rule; type_declaration_rule_intf]
716+
~rules:[import_declaration_rule; import_declaration_rule_intf]
736717
"ppx_import"

‎src_test/ppx_deriving/errors/run.t

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -116,8 +116,7 @@ It's been fixed for later versions in https://github.com/ocaml/ocaml/pull/8541
116116
1 | [%%import:
117117
2 | type b = int
118118
3 | type a = string]
119-
Error: [%%import] Expected exactly one item in the structure or signature,
120-
but found multiple items
119+
Error: [] expected
121120

122121
Ptyp
123122
$ cat >test.ml <<EOF
@@ -128,8 +127,7 @@ Ptyp
128127
File "test.ml", line 1, characters 0-18:
129128
1 | [%%import: string]
130129
^^^^^^^^^^^^^^^^^^
131-
Error: [%%import] Type pattern (PTyp) is not supported, only type and module
132-
type declarations are allowed
130+
Error: PStr expected
133131
[1]
134132

135133
Inline module type declaration

‎src_test/ppx_deriving/errors_lte_407/run.t

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -112,9 +112,7 @@ Ptyp
112112
File "test.ml", line 1, characters 0-18:
113113
1 | [%%import: string]
114114
^^^^^^^^^^^^^^^^^^
115-
Error: [%%import] Invalid extension usage. [%%import] only supports structure
116-
items, signatures or type declarations, but a type pattern (PTyp) was
117-
found.
115+
Error: PStr expected
118116
[1]
119117

120118
Inline module type declaration

0 commit comments

Comments
 (0)