Skip to content

Commit 7b55928

Browse files
committed
implement new module type syntax
<!-- ps-id: 144ef8fa-2d04-4b5a-9077-11afcc4283c7 -->
1 parent 1e5d960 commit 7b55928

File tree

7 files changed

+275
-155
lines changed

7 files changed

+275
-155
lines changed

src/ppx_import.ml

Lines changed: 146 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -508,17 +508,54 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) :
508508
| [] -> []
509509
| _ -> assert false
510510

511-
let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
511+
let subst_of_constraint (const : Ppxlib.with_constraint) =
512512
let open Ppxlib in
513-
try
514-
let ({txt = lid; loc} as alias), subst = package_type in
513+
match const with
514+
| Parsetree.Pwith_type (longident, type_decl) -> (
515+
match type_decl with
516+
| {ptype_manifest = Some core_type; _} -> (longident, core_type)
517+
| {ptype_loc; _} ->
518+
raise_error ~loc:ptype_loc "[%%import]: Not supported type_decl" )
519+
| Parsetree.Pwith_module ({loc; _}, _) ->
520+
raise_error ~loc "[%%import]: Pwith_module constraint is not supported."
521+
| Parsetree.Pwith_modtype ({loc; _}, _) ->
522+
raise_error ~loc "[%%import]: Pwith_modtype constraint is not supported."
523+
| Parsetree.Pwith_modtypesubst ({loc; _}, _) ->
524+
raise_error ~loc
525+
"[%%import]: Pwith_modtypesubst constraint is not supported."
526+
| Parsetree.Pwith_typesubst ({loc; _}, _) ->
527+
raise_error ~loc "[%%import]: Pwith_typesubst constraint is not supported."
528+
| Parsetree.Pwith_modsubst ({loc; _}, _) ->
529+
raise_error ~loc "[%%import]: Pwith_modsubst constraint is not supported."
530+
531+
let rec module_type ~tool_name ~input_name ?(subst = []) modtype =
532+
let open Ppxlib in
533+
let {pmty_desc; pmty_loc; _} = modtype in
534+
match pmty_desc with
535+
| Pmty_signature _ ->
536+
(* Ex: module type%import Hashable = sig ... end *)
537+
raise_error ~loc:pmty_loc
538+
"[%%import] inline module type declaration is not supported"
539+
| Pmty_with (modtype, constraints) ->
540+
let subst = constraints |> List.map subst_of_constraint in
541+
module_type ~tool_name ~input_name ~subst modtype
542+
| Pmty_functor (_, _) ->
543+
raise_error ~loc:pmty_loc "[%%import] module type doesn't support functor"
544+
| Pmty_typeof _ ->
545+
raise_error ~loc:pmty_loc "[%%import] module type doesn't support typeof"
546+
| Pmty_extension _ ->
547+
raise_error ~loc:pmty_loc "[%%import] module type doesn't support extension"
548+
| Pmty_alias _ ->
549+
raise_error ~loc:pmty_loc "[%%import] module type doesn't support alias"
550+
| Pmty_ident longident ->
551+
let {txt = lid; loc} = longident in
515552
if tool_name = "ocamldep" then
516553
if is_self_reference ~input_name ~loc lid then
517554
(* Create a dummy module type to break the circular dependency *)
518555
Ast_helper.Mty.mk ~attrs:[] (Pmty_signature [])
519556
else
520557
(* Just put it as alias *)
521-
Ast_helper.Mty.mk ~attrs:[] (Pmty_alias alias)
558+
Ast_helper.Mty.mk ~attrs:[] (Pmty_alias longident)
522559
else
523560
Ppxlib.Ast_helper.with_default_loc loc (fun () ->
524561
let env = Lazy.force lazy_env in
@@ -552,6 +589,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
552589
| {mtd_type = None; _} ->
553590
raise_error ~loc "Imported module is abstract"
554591
| _ -> raise_error ~loc "Imported module is indirectly defined" )
592+
593+
let module_type_decl ~tool_name ~input_name
594+
(modtype_decl : Ppxlib.module_type_declaration) =
595+
let open Ppxlib in
596+
try
597+
let {pmtd_type; pmtd_loc; _} = modtype_decl in
598+
match pmtd_type with
599+
| None ->
600+
(* when there's nothing after the equal sign. Ex: module type%import Hashable *)
601+
raise_error ~loc:pmtd_loc
602+
"[%%import] module type declaration is missing the module type \
603+
definition"
604+
| Some modtype -> module_type ~tool_name ~input_name modtype
555605
with Error {loc; error} ->
556606
let ext = Ppxlib.Location.error_extensionf ~loc "%s" error in
557607
Ast_builder.Default.pmty_extension ~loc ext
@@ -574,41 +624,113 @@ let type_declaration_expand_intf ~ctxt rec_flag type_decls =
574624
in
575625
Ppxlib.Ast_builder.Default.(psig_type ~loc rec_flag type_decls)
576626

577-
let module_declaration_expand ~ctxt package_type =
627+
let module_declaration_expand ~ctxt modtype_decl =
628+
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
578629
let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in
579630
let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in
580-
module_type ~tool_name ~input_name package_type
631+
let modtype = module_type_decl ~tool_name ~input_name modtype_decl in
632+
let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in
633+
let md_decl =
634+
Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name
635+
~typ:modtype
636+
in
637+
Ppxlib.{pstr_desc = Pstr_modtype md_decl; pstr_loc = loc}
638+
639+
let module_declaration_expand_intf ~ctxt modtype_decl =
640+
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
641+
let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in
642+
let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in
643+
let modtype = module_type_decl ~tool_name ~input_name modtype_decl in
644+
let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in
645+
let md_decl =
646+
Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name
647+
~typ:modtype
648+
in
649+
Ppxlib.{psig_desc = Psig_modtype md_decl; psig_loc = loc}
650+
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
657+
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); _}] ->
660+
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; _}] ->
663+
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"
581683

582684
let type_declaration_extension =
583685
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item
584-
Ppxlib.Ast_pattern.(
585-
psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) )
586-
type_declaration_expand
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
695+
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); _}] ->
698+
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; _}] ->
701+
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"
587721

588722
let type_declaration_extension_intf =
589723
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item
590-
Ppxlib.Ast_pattern.(
591-
psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) )
592-
type_declaration_expand_intf
593-
594-
let module_declaration_extension =
595-
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.module_type
596-
Ppxlib.Ast_pattern.(ptyp (ptyp_package __))
597-
module_declaration_expand
724+
Ppxlib.Ast_pattern.(__)
725+
type_declaration_expander_intf
598726

599727
let type_declaration_rule =
600728
Ppxlib.Context_free.Rule.extension type_declaration_extension
601729

602730
let type_declaration_rule_intf =
603731
Ppxlib.Context_free.Rule.extension type_declaration_extension_intf
604732

605-
let module_declaration_rule =
606-
Ppxlib.Context_free.Rule.extension module_declaration_extension
607-
608733
let () =
609734
Ppxlib.Driver.V2.register_transformation
610-
~rules:
611-
[ type_declaration_rule
612-
; module_declaration_rule
613-
; type_declaration_rule_intf ]
735+
~rules:[type_declaration_rule; type_declaration_rule_intf]
614736
"ppx_import"

0 commit comments

Comments
 (0)