@@ -508,17 +508,54 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) :
508
508
| [] -> []
509
509
| _ -> assert false
510
510
511
- let module_type ~ tool_name ~ input_name ( package_type : Ppxlib.package_type ) =
511
+ let subst_of_constraint ( const : Ppxlib.with_constraint ) =
512
512
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
515
552
if tool_name = " ocamldep" then
516
553
if is_self_reference ~input_name ~loc lid then
517
554
(* Create a dummy module type to break the circular dependency *)
518
555
Ast_helper.Mty. mk ~attrs: [] (Pmty_signature [] )
519
556
else
520
557
(* Just put it as alias *)
521
- Ast_helper.Mty. mk ~attrs: [] (Pmty_alias alias )
558
+ Ast_helper.Mty. mk ~attrs: [] (Pmty_alias longident )
522
559
else
523
560
Ppxlib.Ast_helper. with_default_loc loc (fun () ->
524
561
let env = Lazy. force lazy_env in
@@ -552,6 +589,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
552
589
| {mtd_type = None ; _} ->
553
590
raise_error ~loc " Imported module is abstract"
554
591
| _ -> 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
555
605
with Error {loc; error} ->
556
606
let ext = Ppxlib.Location. error_extensionf ~loc " %s" error in
557
607
Ast_builder.Default. pmty_extension ~loc ext
@@ -574,41 +624,113 @@ let type_declaration_expand_intf ~ctxt rec_flag type_decls =
574
624
in
575
625
Ppxlib.Ast_builder.Default. (psig_type ~loc rec_flag type_decls)
576
626
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
578
629
let tool_name = Ppxlib.Expansion_context.Extension. tool_name ctxt in
579
630
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"
581
683
582
684
let type_declaration_extension =
583
685
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"
587
721
588
722
let type_declaration_extension_intf =
589
723
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
598
726
599
727
let type_declaration_rule =
600
728
Ppxlib.Context_free.Rule. extension type_declaration_extension
601
729
602
730
let type_declaration_rule_intf =
603
731
Ppxlib.Context_free.Rule. extension type_declaration_extension_intf
604
732
605
- let module_declaration_rule =
606
- Ppxlib.Context_free.Rule. extension module_declaration_extension
607
-
608
733
let () =
609
734
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]
614
736
" ppx_import"
0 commit comments