Skip to content

Commit

Permalink
implement new module type syntax
Browse files Browse the repository at this point in the history 
<!-- ps-id: 144ef8fa-2d04-4b5a-9077-11afcc4283c7 -->
  • Loading branch information
@tatchi
tatchi committed Feb 23, 2023
1 parent 807ae22 commit 4ebeb19
Show file tree
Hide file tree
Showing 7 changed files with 275 additions and 155 deletions.
170 changes: 146 additions & 24 deletions src/ppx_import.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -508,17 +508,54 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) :
| [] -> []
| _ -> assert false

let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
let subst_of_constraint (const : Ppxlib.with_constraint) =
let open Ppxlib in
try
let ({txt = lid; loc} as alias), subst = package_type in
match const with
| Parsetree.Pwith_type (longident, type_decl) -> (
match type_decl with
| {ptype_manifest = Some core_type; _} -> (longident, core_type)
| {ptype_loc; _} ->
raise_error ~loc:ptype_loc "[%%import]: Not supported type_decl" )
| Parsetree.Pwith_module ({loc; _}, _) ->
raise_error ~loc "[%%import]: Pwith_module constraint is not supported."
| Parsetree.Pwith_modtype ({loc; _}, _) ->
raise_error ~loc "[%%import]: Pwith_modtype constraint is not supported."
| Parsetree.Pwith_modtypesubst ({loc; _}, _) ->
raise_error ~loc
"[%%import]: Pwith_modtypesubst constraint is not supported."
| Parsetree.Pwith_typesubst ({loc; _}, _) ->
raise_error ~loc "[%%import]: Pwith_typesubst constraint is not supported."
| Parsetree.Pwith_modsubst ({loc; _}, _) ->
raise_error ~loc "[%%import]: Pwith_modsubst constraint is not supported."

let rec module_type ~tool_name ~input_name ?(subst = []) modtype =
let open Ppxlib in
let {pmty_desc; pmty_loc; _} = modtype in
match pmty_desc with
| Pmty_signature _ ->
(* Ex: module type%import Hashable = sig ... end *)
raise_error ~loc:pmty_loc
"[%%import] inline module type declaration is not supported"
| Pmty_with (modtype, constraints) ->
let subst = constraints |> List.map subst_of_constraint in
module_type ~tool_name ~input_name ~subst modtype
| Pmty_functor (_, _) ->
raise_error ~loc:pmty_loc "[%%import] module type doesn't support functor"
| Pmty_typeof _ ->
raise_error ~loc:pmty_loc "[%%import] module type doesn't support typeof"
| Pmty_extension _ ->
raise_error ~loc:pmty_loc "[%%import] module type doesn't support extension"
| Pmty_alias _ ->
raise_error ~loc:pmty_loc "[%%import] module type doesn't support alias"
| Pmty_ident longident ->
let {txt = lid; loc} = longident in
if tool_name = "ocamldep" then
if is_self_reference ~input_name ~loc lid then
(* Create a dummy module type to break the circular dependency *)
Ast_helper.Mty.mk ~attrs:[] (Pmty_signature [])
else
(* Just put it as alias *)
Ast_helper.Mty.mk ~attrs:[] (Pmty_alias alias)
Ast_helper.Mty.mk ~attrs:[] (Pmty_alias longident)
else
Ppxlib.Ast_helper.with_default_loc loc (fun () ->
let env = Lazy.force lazy_env in
Expand Down Expand Up @@ -552,6 +589,19 @@ let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
| {mtd_type = None; _} ->
raise_error ~loc "Imported module is abstract"
| _ -> raise_error ~loc "Imported module is indirectly defined" )

let module_type_decl ~tool_name ~input_name
(modtype_decl : Ppxlib.module_type_declaration) =
let open Ppxlib in
try
let {pmtd_type; pmtd_loc; _} = modtype_decl in
match pmtd_type with
| None ->
(* when there's nothing after the equal sign. Ex: module type%import Hashable *)
raise_error ~loc:pmtd_loc
"[%%import] module type declaration is missing the module type \
definition"
| Some modtype -> module_type ~tool_name ~input_name modtype
with Error {loc; error} ->
let ext = Ppxlib.Location.error_extensionf ~loc "%s" error in
Ast_builder.Default.pmty_extension ~loc ext
Expand All @@ -574,41 +624,113 @@ let type_declaration_expand_intf ~ctxt rec_flag type_decls =
in
Ppxlib.Ast_builder.Default.(psig_type ~loc rec_flag type_decls)

let module_declaration_expand ~ctxt package_type =
let module_declaration_expand ~ctxt modtype_decl =
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in
let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in
module_type ~tool_name ~input_name package_type
let modtype = module_type_decl ~tool_name ~input_name modtype_decl in
let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in
let md_decl =
Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name
~typ:modtype
in
Ppxlib.{pstr_desc = Pstr_modtype md_decl; pstr_loc = loc}

let module_declaration_expand_intf ~ctxt modtype_decl =
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
let tool_name = Ppxlib.Expansion_context.Extension.tool_name ctxt in
let input_name = Ppxlib.Expansion_context.Extension.input_name ctxt in
let modtype = module_type_decl ~tool_name ~input_name modtype_decl in
let Ppxlib.{pmtd_name; pmtd_attributes; pmtd_loc; _} = modtype_decl in
let md_decl =
Ppxlib.Ast_helper.Mtd.mk ~loc:pmtd_loc ~attrs:pmtd_attributes pmtd_name
~typ:modtype
in
Ppxlib.{psig_desc = Psig_modtype md_decl; psig_loc = loc}

let type_declaration_expander ~ctxt payload =
let return_error e =
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in
Ppxlib.Ast_builder.Default.pstr_extension ext [] ~loc
in
match payload with
| Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}]
|Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] ->
type_declaration_expand ~ctxt rec_flag type_decls
| Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}]
|Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] ->
module_declaration_expand ~ctxt modtype_decl
| Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] ->
return_error
"[%%import] Expected a type declaration or a module type declaration"
| Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) ->
return_error
"[%%import] Expected exactly one item in the structure or signature, but \
found multiple items"
| Parsetree.PStr [] | Parsetree.PSig [] ->
return_error
"[%%import] Expected exactly one item in the structure or signature, but \
found none"
| Parsetree.PTyp _ ->
return_error
"[%%import] Type pattern (PTyp) is not supported, only type and module \
type declarations are allowed"
| Parsetree.PPat (_, _) ->
return_error
"[%%import] Pattern (PPat) is not supported, only type and module type \
declarations are allowed"

let type_declaration_extension =
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.structure_item
Ppxlib.Ast_pattern.(
psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) )
type_declaration_expand
Ppxlib.Ast_pattern.(__)
type_declaration_expander

let type_declaration_expander_intf ~ctxt payload =
let return_error e =
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
let ext = Ppxlib.Location.error_extensionf ~loc "%s" e in
Ppxlib.Ast_builder.Default.psig_extension ext [] ~loc
in
match payload with
| Parsetree.PStr [{pstr_desc = Pstr_type (rec_flag, type_decls); _}]
|Parsetree.PSig [{psig_desc = Psig_type (rec_flag, type_decls); _}] ->
type_declaration_expand_intf ~ctxt rec_flag type_decls
| Parsetree.PStr [{pstr_desc = Pstr_modtype modtype_decl; _}]
|Parsetree.PSig [{psig_desc = Psig_modtype modtype_decl; _}] ->
module_declaration_expand_intf ~ctxt modtype_decl
| Parsetree.PStr [{pstr_desc = _; _}] | Parsetree.PSig [{psig_desc = _; _}] ->
return_error
"[%%import] Expected a type declaration or a module type declaration"
| Parsetree.PStr (_ :: _) | Parsetree.PSig (_ :: _) ->
return_error
"[%%import] Expected exactly one item in the structure or signature, but \
found multiple items"
| Parsetree.PStr [] | Parsetree.PSig [] ->
return_error
"[%%import] Expected exactly one item in the structure or signature, but \
found none"
| Parsetree.PTyp _ ->
return_error
"[%%import] Type pattern (PTyp) is not supported, only type and module \
type declarations are allowed"
| Parsetree.PPat (_, _) ->
return_error
"[%%import] Pattern (PPat) is not supported, only type and module type \
declarations are allowed"

let type_declaration_extension_intf =
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.signature_item
Ppxlib.Ast_pattern.(
psig (psig_type __ __ ^:: nil) ||| pstr (pstr_type __ __ ^:: nil) )
type_declaration_expand_intf

let module_declaration_extension =
Ppxlib.Extension.V3.declare "import" Ppxlib.Extension.Context.module_type
Ppxlib.Ast_pattern.(ptyp (ptyp_package __))
module_declaration_expand
Ppxlib.Ast_pattern.(__)
type_declaration_expander_intf

let type_declaration_rule =
Ppxlib.Context_free.Rule.extension type_declaration_extension

let type_declaration_rule_intf =
Ppxlib.Context_free.Rule.extension type_declaration_extension_intf

let module_declaration_rule =
Ppxlib.Context_free.Rule.extension module_declaration_extension

let () =
Ppxlib.Driver.V2.register_transformation
~rules:
[ type_declaration_rule
; module_declaration_rule
; type_declaration_rule_intf ]
~rules:[type_declaration_rule; type_declaration_rule_intf]
"ppx_import"
Loading

0 comments on commit 4ebeb19

Please sign in to comment.