Skip to content

Commit

Permalink
Merge pull request #73 from tatchi/avoid-raising-errors
Browse files Browse the repository at this point in the history 
Avoid raising errors
  • Loading branch information
@ejgallego
ejgallego authored Feb 5, 2023
2 parents 1960006 + d03f272 commit 54e5278
Show file tree
Hide file tree
Showing 3 changed files with 185 additions and 121 deletions.
272 changes: 168 additions & 104 deletions src/ppx_import.ml
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,11 @@
module Tt = Ppx_types_migrate

type error = {loc : Location.t; error : string}

exception Error of error

let raise_error ~loc error = raise (Error {loc; error})

let lazy_env =
lazy
( (* It is important that the typing environment is not evaluated
Expand Down Expand Up @@ -66,9 +72,12 @@ let try_find_module_type ~loc env lid =
Some
( match modtype_decl.mtd_type with
| None ->
Location.raise_errorf ~loc
"[%%import]: cannot access the signature of the abstract module %s"
(string_of_lid lid)
let error =
Printf.sprintf
"[%%import]: cannot access the signature of the abstract module %s"
(string_of_lid lid)
in
raise_error ~loc error
| Some module_type -> module_type )
with Not_found -> None

Expand All @@ -87,14 +96,24 @@ let open_module_type ~loc env lid module_type =
match try_open_module_type env module_type with
| Some sig_items -> sig_items
| None ->
Location.raise_errorf ~loc "[%%import]: cannot find the components of %s"
(string_of_lid lid)
let error =
Printf.sprintf "[%%import]: cannot find the components of %s"
(string_of_lid lid)
in
raise_error ~loc error

let locate_sig ~loc env lid =
let head, path =
match Ppxlib.Longident.flatten_exn lid with
| head :: path -> (Longident.Lident head, path)
| _ -> assert false
try
match Ppxlib.Longident.flatten_exn lid with
| head :: path -> (Longident.Lident head, path)
| _ -> assert false
with Invalid_argument _ ->
let error =
Printf.sprintf "[%%import] cannot import a functor application %s"
(string_of_lid lid)
in
raise_error ~loc error
in
let head_module_type =
match
Expand All @@ -103,8 +122,10 @@ let locate_sig ~loc env lid =
| Some mty, _ -> mty
| None, (lazy (Some mty)) -> mty
| None, (lazy None) ->
Location.raise_errorf ~loc "[%%import]: cannot locate module %s"
(string_of_lid lid)
let error =
Printf.sprintf "[%%import]: cannot locate module %s" (string_of_lid lid)
in
raise_error ~loc error
in
let get_sub_module_type (lid, module_type) path_item =
let sig_items = open_module_type ~loc env lid module_type in
Expand All @@ -117,9 +138,11 @@ let locate_sig ~loc env lid =
md_type
| _ :: sig_items -> loop sig_items
| [] ->
Location.raise_errorf ~loc
"[%%import]: cannot find the signature of %s in %s" path_item
(string_of_lid lid)
let error =
Printf.sprintf "[%%import]: cannot find the signature of %s in %s"
path_item (string_of_lid lid)
in
raise_error ~loc error
in
let sub_module_type =
loop (List.map Compat.migrate_signature_item sig_items)
Expand Down Expand Up @@ -148,8 +171,11 @@ let get_type_decl ~loc sig_items parent_lid elem =
in
match try_get_tsig_item select_type ~loc sig_items elem with
| None ->
Location.raise_errorf "[%%import]: cannot find the type %s in %s" elem
(string_of_lid parent_lid)
let error =
Printf.sprintf "[%%import]: cannot find the type %s in %s" elem
(string_of_lid parent_lid)
in
raise_error ~loc error
| Some decl -> decl

let get_modtype_decl ~loc sig_items parent_lid elem =
Expand All @@ -160,8 +186,11 @@ let get_modtype_decl ~loc sig_items parent_lid elem =
in
match try_get_tsig_item select_modtype ~loc sig_items elem with
| None ->
Location.raise_errorf "[%%import]: cannot find the module type %s in %s"
elem (string_of_lid parent_lid)
let error =
Printf.sprintf "[%%import]: cannot find the module type %s in %s" elem
(string_of_lid parent_lid)
in
raise_error ~loc error
| Some decl -> decl

let longident_of_path = Untypeast.lident_of_path
Expand Down Expand Up @@ -239,10 +268,12 @@ let ptype_decl_of_ttype_decl ~manifest ~subst ptype_name
ttype_decl.type_params ptype_args
|> List.concat
with Invalid_argument _ ->
Location.raise_errorf ~loc:ptyp_loc
"Imported type has %d parameter(s), but %d are passed"
(List.length ttype_decl.type_params)
(List.length ptype_args) )
let error =
Printf.sprintf "Imported type has %d parameter(s), but %d are passed"
(List.length ttype_decl.type_params)
(List.length ptype_args)
in
raise_error ~loc:ptyp_loc error )
| None -> []
| _ -> assert false
in
Expand Down Expand Up @@ -337,8 +368,7 @@ let subst_of_manifest ({ptyp_attributes; ptyp_loc; _} : Ppxlib.core_type) =
; ptyp_attributes = pexp_attributes
; ptyp_desc = Ptyp_constr (dst, []) } )
:: subst_of_expr rest
| {pexp_loc; _} ->
Location.raise_errorf ~loc:pexp_loc "Invalid [@with] syntax"
| {pexp_loc; _} -> raise_error ~loc:pexp_loc "Invalid [@with] syntax"
in
let find_attr s attrs =
try
Expand All @@ -348,18 +378,25 @@ let subst_of_manifest ({ptyp_attributes; ptyp_loc; _} : Ppxlib.core_type) =
match find_attr "with" ptyp_attributes with
| None -> []
| Some (PStr [{pstr_desc = Pstr_eval (expr, []); _}]) -> subst_of_expr expr
| Some _ -> Location.raise_errorf ~loc:ptyp_loc "Invalid [@with] syntax"
| Some _ -> raise_error ~loc:ptyp_loc "Invalid [@with] syntax"

let uncapitalize = String.uncapitalize_ascii

let is_self_reference ~input_name lid =
let is_self_reference ~input_name ~loc lid =
let fn =
input_name |> Filename.basename |> Filename.chop_extension |> uncapitalize
in
match lid with
| Ppxlib.Ldot _ ->
let mn = Ppxlib.Longident.flatten_exn lid |> List.hd |> uncapitalize in
fn = mn
| Ppxlib.Ldot _ -> (
try
let mn = Ppxlib.Longident.flatten_exn lid |> List.hd |> uncapitalize in
fn = mn
with Invalid_argument _ ->
let error =
Printf.sprintf "[%%import] cannot import a functor application %s"
(string_of_lid lid)
in
raise_error ~loc error )
| _ -> false

let type_declaration ~tool_name ~input_name (type_decl : Ppxlib.type_declaration)
Expand All @@ -370,47 +407,56 @@ let type_declaration ~tool_name ~input_name (type_decl : Ppxlib.type_declaration
; ptype_name
; ptype_manifest =
Some ({ptyp_desc = Ptyp_constr ({txt = lid; loc}, _); _} as manifest)
; _ } ->
if tool_name = "ocamldep" then
(* Just put it as manifest *)
if is_self_reference ~input_name lid then
{type_decl with ptype_manifest = None}
else {type_decl with ptype_manifest = Some manifest}
else
Ast_helper.with_default_loc loc (fun () ->
let ttype_decl =
let env = Lazy.force lazy_env in
match lid with
| Lapply _ ->
Location.raise_errorf ~loc
"[%%import] cannot import a functor application %s"
(string_of_lid lid)
| Lident _ as head_id ->
(* In this case, we know for sure that the user intends this lident
as a type name, so we use Typetexp.find_type and let the failure
cases propagate to the user. *)
Compat.find_type env ~loc head_id |> snd
| Ldot (parent_id, elem) ->
let sig_items = locate_sig ~loc env parent_id in
get_type_decl ~loc sig_items parent_id elem
in
let m, s =
if is_self_reference ~input_name lid then (None, [])
else
let subst = subst_of_manifest manifest in
let subst =
subst
@ [ ( `Lid (Lident (Longident.last_exn lid))
, Ast_helper.Typ.constr
{txt = Lident ptype_name.txt; loc = ptype_name.loc}
[] ) ]
in
(Some manifest, subst)
in
let ptype_decl =
ptype_decl_of_ttype_decl ~manifest:m ~subst:s ptype_name ttype_decl
in
{ptype_decl with ptype_attributes} )
; _ } -> (
try
if tool_name = "ocamldep" then
(* Just put it as manifest *)
if is_self_reference ~input_name ~loc lid then
{type_decl with ptype_manifest = None}
else {type_decl with ptype_manifest = Some manifest}
else
Ast_helper.with_default_loc loc (fun () ->
let ttype_decl =
let env = Lazy.force lazy_env in
match lid with
| Lapply _ ->
let error =
Printf.sprintf
"[%%import] cannot import a functor application %s"
(string_of_lid lid)
in
raise_error ~loc error
| Lident _ as head_id ->
(* In this case, we know for sure that the user intends this lident
as a type name, so we use Typetexp.find_type and let the failure
cases propagate to the user. *)
Compat.find_type env ~loc head_id |> snd
| Ldot (parent_id, elem) ->
let sig_items = locate_sig ~loc env parent_id in
get_type_decl ~loc sig_items parent_id elem
in
let m, s =
if is_self_reference ~input_name ~loc lid then (None, [])
else
let subst = subst_of_manifest manifest in
let subst =
subst
@ [ ( `Lid (Lident (Longident.last_exn lid))
, Ast_helper.Typ.constr
{txt = Lident ptype_name.txt; loc = ptype_name.loc}
[] ) ]
in
(Some manifest, subst)
in
let ptype_decl =
ptype_decl_of_ttype_decl ~manifest:m ~subst:s ptype_name
ttype_decl
in
{ptype_decl with ptype_attributes} )
with Error {loc; error} ->
let ext = Ppxlib.Location.error_extensionf ~loc "%s" error in
let core_type = Ast_builder.Default.ptyp_extension ~loc ext in
{type_decl with ptype_manifest = Some core_type} )
| _ -> type_decl

let rec cut_tsig_block_of_rec_types accu (tsig : Compat.signature_item_407 list)
Expand Down Expand Up @@ -464,42 +510,60 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) :

let module_type ~tool_name ~input_name (package_type : Ppxlib.package_type) =
let open Ppxlib in
let ({txt = lid; loc} as alias), subst = package_type in
if tool_name = "ocamldep" then
if is_self_reference ~input_name 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)
else
Ppxlib.Ast_helper.with_default_loc loc (fun () ->
let env = Lazy.force lazy_env in
let tmodtype_decl =
match lid with
| Longident.Lapply _ ->
Location.raise_errorf ~loc
"[%%import] cannot import a functor application %s"
(string_of_lid lid)
| Longident.Lident _ as head_id ->
(* In this case, we know for sure that the user intends this lident
as a module type name, so we use Typetexp.find_type and
let the failure cases propagate to the user. *)
Compat.find_modtype env ~loc head_id |> snd
| Longident.Ldot (parent_id, elem) ->
let sig_items = locate_sig ~loc env parent_id in
get_modtype_decl ~loc sig_items parent_id elem
in
match tmodtype_decl with
| {mtd_type = Some (Mty_signature tsig); _} ->
let subst = List.map (fun ({txt; _}, typ) -> (`Lid txt, typ)) subst in
let psig =
psig_of_tsig ~subst (List.map Compat.migrate_signature_item tsig)
try
let ({txt = lid; loc} as alias), subst = package_type 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)
else
Ppxlib.Ast_helper.with_default_loc loc (fun () ->
let env = Lazy.force lazy_env in
let tmodtype_decl =
match lid with
| Longident.Lapply _ ->
let error =
Printf.sprintf
"[%%import] cannot import a functor application %s"
(string_of_lid lid)
in
raise_error ~loc error
| Longident.Lident _ as head_id ->
(* In this case, we know for sure that the user intends this lident
as a module type name, so we use Typetexp.find_type and
let the failure cases propagate to the user. *)
Compat.find_modtype env ~loc head_id |> snd
| Longident.Ldot (parent_id, elem) ->
let sig_items = locate_sig ~loc env parent_id in
get_modtype_decl ~loc sig_items parent_id elem
in
Ast_helper.Mty.mk ~attrs:[] (Pmty_signature psig)
| {mtd_type = None; _} ->
Location.raise_errorf ~loc "Imported module is abstract"
| _ ->
Location.raise_errorf ~loc "Imported module is indirectly defined" )
match tmodtype_decl with
| {mtd_type = Some (Mty_signature tsig); _} ->
let subst =
List.map (fun ({txt; _}, typ) -> (`Lid txt, typ)) subst
in
let psig =
psig_of_tsig ~subst (List.map Compat.migrate_signature_item tsig)
in
Ast_helper.Mty.mk ~attrs:[] (Pmty_signature psig)
| {mtd_type = None; _} ->
let ext =
Ppxlib.Location.error_extensionf ~loc
"Imported module is abstract"
in
Ast_builder.Default.pmty_extension ~loc ext
| _ ->
let ext =
Ppxlib.Location.error_extensionf ~loc
"Imported module is indirectly defined"
in
Ast_builder.Default.pmty_extension ~loc ext )
with Error {loc; error} ->
let ext = Ppxlib.Location.error_extensionf ~loc "%s" error in
Ast_builder.Default.pmty_extension ~loc ext

let type_declaration_expand ~ctxt rec_flag type_decls =
let loc = Ppxlib.Expansion_context.Extension.extension_point_loc ctxt in
Expand Down
18 changes: 10 additions & 8 deletions src_test/ppx_deriving/errors/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,13 +13,13 @@ Functor error
> [%%import: type t = Map.Make(String).t]
> EOF

$ dune build 2>&1 | sed 's/\(Command line: \).*/\1Error/'
File ".test.objs/byte/_unknown_", line 1, characters 0-0:
Fatal error: exception Invalid_argument("Ppxlib.Longident.flatten")
File "test.ml", line 1:
Error: Error while running external preprocessor
Command line: Error
$ dune build
File "test.ml", line 1, characters 21-39:
1 | [%%import: type t = Map.Make(String).t]
^^^^^^^^^^^^^^^^^^
Error: [%import] cannot import a functor application Map.Make(String)
[1]

Parameters error
$ cat >test.ml <<EOF
> [%%import: type t = List.t]
Expand Down Expand Up @@ -96,6 +96,8 @@ Cannot find module error
> EOF

$ dune build
File "_none_", line 1:
File "test.ml", line 1, characters 34-43:
1 | module type A = [%import: (module Stuff.S.M)]
^^^^^^^^^
Error: [%import]: cannot find the module type M in Stuff.S
[1]
Loading

0 comments on commit 54e5278

Please sign in to comment.