2012-05-30 08:25:49 -07:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
2016-02-18 07:11:59 -08:00
|
|
|
(* OCaml *)
|
2012-05-30 08:25:49 -07:00
|
|
|
(* *)
|
|
|
|
(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *)
|
|
|
|
(* *)
|
|
|
|
(* Copyright 2007 Institut National de Recherche en Informatique et *)
|
2016-02-18 07:11:59 -08:00
|
|
|
(* en Automatique. *)
|
|
|
|
(* *)
|
|
|
|
(* All rights reserved. This file is distributed under the terms of *)
|
|
|
|
(* the GNU Lesser General Public License version 2.1, with the *)
|
|
|
|
(* special exception on linking described in the file LICENSE. *)
|
2012-05-30 08:25:49 -07:00
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
open Longident
|
2012-05-30 08:25:49 -07:00
|
|
|
open Asttypes
|
|
|
|
open Parsetree
|
2013-03-08 06:59:45 -08:00
|
|
|
open Ast_helper
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
module T = Typedtree
|
|
|
|
|
|
|
|
type mapper = {
|
|
|
|
attribute: mapper -> T.attribute -> attribute;
|
|
|
|
attributes: mapper -> T.attribute list -> attribute list;
|
|
|
|
case: mapper -> T.case -> case;
|
|
|
|
cases: mapper -> T.case list -> case list;
|
|
|
|
class_declaration: mapper -> T.class_declaration -> class_declaration;
|
|
|
|
class_description: mapper -> T.class_description -> class_description;
|
|
|
|
class_expr: mapper -> T.class_expr -> class_expr;
|
|
|
|
class_field: mapper -> T.class_field -> class_field;
|
|
|
|
class_signature: mapper -> T.class_signature -> class_signature;
|
|
|
|
class_structure: mapper -> T.class_structure -> class_structure;
|
|
|
|
class_type: mapper -> T.class_type -> class_type;
|
|
|
|
class_type_declaration: mapper -> T.class_type_declaration
|
|
|
|
-> class_type_declaration;
|
|
|
|
class_type_field: mapper -> T.class_type_field -> class_type_field;
|
|
|
|
constructor_declaration: mapper -> T.constructor_declaration
|
|
|
|
-> constructor_declaration;
|
|
|
|
expr: mapper -> T.expression -> expression;
|
|
|
|
extension_constructor: mapper -> T.extension_constructor
|
|
|
|
-> extension_constructor;
|
|
|
|
include_declaration: mapper -> T.include_declaration -> include_declaration;
|
|
|
|
include_description: mapper -> T.include_description -> include_description;
|
|
|
|
label_declaration: mapper -> T.label_declaration -> label_declaration;
|
|
|
|
location: mapper -> Location.t -> Location.t;
|
|
|
|
module_binding: mapper -> T.module_binding -> module_binding;
|
|
|
|
module_declaration: mapper -> T.module_declaration -> module_declaration;
|
|
|
|
module_expr: mapper -> T.module_expr -> module_expr;
|
|
|
|
module_type: mapper -> T.module_type -> module_type;
|
|
|
|
module_type_declaration:
|
|
|
|
mapper -> T.module_type_declaration -> module_type_declaration;
|
|
|
|
package_type: mapper -> T.package_type -> package_type;
|
|
|
|
open_description: mapper -> T.open_description -> open_description;
|
|
|
|
pat: mapper -> T.pattern -> pattern;
|
|
|
|
row_field: mapper -> T.row_field -> row_field;
|
2017-03-09 20:46:48 -08:00
|
|
|
object_field: mapper -> T.object_field -> object_field;
|
2015-03-08 03:22:35 -07:00
|
|
|
signature: mapper -> T.signature -> signature;
|
|
|
|
signature_item: mapper -> T.signature_item -> signature_item;
|
|
|
|
structure: mapper -> T.structure -> structure;
|
|
|
|
structure_item: mapper -> T.structure_item -> structure_item;
|
|
|
|
typ: mapper -> T.core_type -> core_type;
|
|
|
|
type_declaration: mapper -> T.type_declaration -> type_declaration;
|
|
|
|
type_extension: mapper -> T.type_extension -> type_extension;
|
|
|
|
type_kind: mapper -> T.type_kind -> type_kind;
|
|
|
|
value_binding: mapper -> T.value_binding -> value_binding;
|
|
|
|
value_description: mapper -> T.value_description -> value_description;
|
|
|
|
with_constraint:
|
|
|
|
mapper -> (Path.t * Longident.t Location.loc * T.with_constraint)
|
|
|
|
-> with_constraint;
|
|
|
|
}
|
|
|
|
|
|
|
|
open T
|
|
|
|
|
2012-05-30 08:25:49 -07:00
|
|
|
(*
|
|
|
|
Some notes:
|
|
|
|
|
|
|
|
* For Pexp_function, we cannot go back to the exact original version
|
|
|
|
when there is a default argument, because the default argument is
|
|
|
|
translated in the typer. The code, if printed, will not be parsable because
|
|
|
|
new generated identifiers are not correct.
|
|
|
|
|
|
|
|
* For Pexp_apply, it is unclear whether arguments are reordered, especially
|
|
|
|
when there are optional arguments.
|
|
|
|
|
|
|
|
*)
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
|
|
|
|
(** Utility functions. *)
|
|
|
|
|
2014-08-22 06:45:02 -07:00
|
|
|
let string_is_prefix sub str =
|
|
|
|
let sublen = String.length sub in
|
|
|
|
String.length str >= sublen && String.sub str 0 sublen = sub
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let map_opt f = function None -> None | Some e -> Some (f e)
|
|
|
|
|
|
|
|
let rec lident_of_path = function
|
|
|
|
| Path.Pident id -> Longident.Lident (Ident.name id)
|
|
|
|
| Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s)
|
|
|
|
| Path.Papply (p1, p2) ->
|
|
|
|
Longident.Lapply (lident_of_path p1, lident_of_path p2)
|
|
|
|
|
|
|
|
let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt}
|
|
|
|
|
|
|
|
(** Try a name [$name$0], check if it's free, if not, increment and repeat. *)
|
|
|
|
let fresh_name s env =
|
|
|
|
let rec aux i =
|
|
|
|
let name = s ^ string_of_int i in
|
|
|
|
try
|
|
|
|
let _ = Env.lookup_value (Lident name) env in
|
|
|
|
name
|
|
|
|
with
|
|
|
|
| Not_found -> aux (i+1)
|
|
|
|
in
|
|
|
|
aux 0
|
|
|
|
|
|
|
|
(** Mapping functions. *)
|
2013-03-25 07:56:56 -07:00
|
|
|
|
2015-04-18 20:07:32 -07:00
|
|
|
let constant = function
|
2016-01-08 06:48:47 -08:00
|
|
|
| Const_char c -> Pconst_char c
|
|
|
|
| Const_string (s,d) -> Pconst_string (s,d)
|
|
|
|
| Const_int i -> Pconst_integer (string_of_int i, None)
|
|
|
|
| Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l')
|
|
|
|
| Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L')
|
|
|
|
| Const_nativeint i -> Pconst_integer (Nativeint.to_string i, Some 'n')
|
|
|
|
| Const_float f -> Pconst_float (f,None)
|
2015-04-18 20:07:32 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let attribute sub (s, p) = (map_loc sub s, p)
|
|
|
|
let attributes sub l = List.map (sub.attribute sub) l
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let structure sub str =
|
|
|
|
List.map (sub.structure_item sub) str.str_items
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let open_description sub od =
|
|
|
|
let loc = sub.location sub od.open_loc in
|
|
|
|
let attrs = sub.attributes sub od.open_attributes in
|
|
|
|
Opn.mk ~loc ~attrs
|
|
|
|
~override:od.open_override
|
|
|
|
(map_loc sub od.open_txt)
|
|
|
|
|
|
|
|
let structure_item sub item =
|
|
|
|
let loc = sub.location sub item.str_loc in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc =
|
|
|
|
match item.str_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs)
|
2013-06-03 08:14:19 -07:00
|
|
|
| Tstr_value (rec_flag, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_value (rec_flag, List.map (sub.value_binding sub) list)
|
2013-03-25 11:04:40 -07:00
|
|
|
| Tstr_primitive vd ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_primitive (sub.value_description sub vd)
|
2015-03-13 04:09:08 -07:00
|
|
|
| Tstr_type (rec_flag, list) ->
|
|
|
|
Pstr_type (rec_flag, List.map (sub.type_declaration sub) list)
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tstr_typext tyext ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_typext (sub.type_extension sub tyext)
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tstr_exception ext ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_exception (sub.extension_constructor sub ext)
|
2013-03-26 01:09:26 -07:00
|
|
|
| Tstr_module mb ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_module (sub.module_binding sub mb)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tstr_recmodule list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_recmodule (List.map (sub.module_binding sub) list)
|
2013-04-18 06:14:53 -07:00
|
|
|
| Tstr_modtype mtd ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_modtype (sub.module_type_declaration sub mtd)
|
2014-04-15 04:26:00 -07:00
|
|
|
| Tstr_open od ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_open (sub.open_description sub od)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tstr_class list ->
|
2014-05-04 16:08:45 -07:00
|
|
|
Pstr_class
|
|
|
|
(List.map
|
2015-03-08 03:22:35 -07:00
|
|
|
(fun (ci, _) -> sub.class_declaration sub ci)
|
2014-05-04 16:08:45 -07:00
|
|
|
list)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tstr_class_type list ->
|
2014-05-04 16:08:45 -07:00
|
|
|
Pstr_class_type
|
|
|
|
(List.map
|
2015-03-08 03:22:35 -07:00
|
|
|
(fun (_id, _name, ct) -> sub.class_type_declaration sub ct)
|
2014-05-04 16:08:45 -07:00
|
|
|
list)
|
2014-04-15 04:26:00 -07:00
|
|
|
| Tstr_include incl ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pstr_include (sub.include_declaration sub incl)
|
2013-03-25 07:16:07 -07:00
|
|
|
| Tstr_attribute x ->
|
|
|
|
Pstr_attribute x
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Str.mk ~loc desc
|
|
|
|
|
|
|
|
let value_description sub v =
|
|
|
|
let loc = sub.location sub v.val_loc in
|
|
|
|
let attrs = sub.attributes sub v.val_attributes in
|
|
|
|
Val.mk ~loc ~attrs
|
|
|
|
~prim:v.val_prim
|
|
|
|
(map_loc sub v.val_name)
|
|
|
|
(sub.typ sub v.val_desc)
|
|
|
|
|
|
|
|
let module_binding sub mb =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub mb.mb_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub mb.mb_attributes in
|
|
|
|
Mb.mk ~loc ~attrs
|
|
|
|
(map_loc sub mb.mb_name)
|
|
|
|
(sub.module_expr sub mb.mb_expr)
|
|
|
|
|
|
|
|
let type_parameter sub (ct, v) = (sub.typ sub ct, v)
|
|
|
|
|
|
|
|
let type_declaration sub decl =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub decl.typ_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub decl.typ_attributes in
|
|
|
|
Type.mk ~loc ~attrs
|
|
|
|
~params:(List.map (type_parameter sub) decl.typ_params)
|
|
|
|
~cstrs:(
|
|
|
|
List.map
|
|
|
|
(fun (ct1, ct2, loc) ->
|
|
|
|
(sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc))
|
|
|
|
decl.typ_cstrs)
|
|
|
|
~kind:(sub.type_kind sub decl.typ_kind)
|
|
|
|
~priv:decl.typ_private
|
|
|
|
?manifest:(map_opt (sub.typ sub) decl.typ_manifest)
|
|
|
|
(map_loc sub decl.typ_name)
|
|
|
|
|
|
|
|
let type_kind sub tk = match tk with
|
|
|
|
| Ttype_abstract -> Ptype_abstract
|
|
|
|
| Ttype_variant list ->
|
|
|
|
Ptype_variant (List.map (sub.constructor_declaration sub) list)
|
|
|
|
| Ttype_record list ->
|
|
|
|
Ptype_record (List.map (sub.label_declaration sub) list)
|
|
|
|
| Ttype_open -> Ptype_open
|
|
|
|
|
|
|
|
let constructor_arguments sub = function
|
|
|
|
| Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l)
|
|
|
|
| Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l)
|
|
|
|
|
|
|
|
let constructor_declaration sub cd =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub cd.cd_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub cd.cd_attributes in
|
|
|
|
Type.constructor ~loc ~attrs
|
|
|
|
~args:(constructor_arguments sub cd.cd_args)
|
|
|
|
?res:(map_opt (sub.typ sub) cd.cd_res)
|
|
|
|
(map_loc sub cd.cd_name)
|
|
|
|
|
|
|
|
let label_declaration sub ld =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ld.ld_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ld.ld_attributes in
|
|
|
|
Type.field ~loc ~attrs
|
|
|
|
~mut:ld.ld_mutable
|
|
|
|
(map_loc sub ld.ld_name)
|
|
|
|
(sub.typ sub ld.ld_type)
|
|
|
|
|
|
|
|
let type_extension sub tyext =
|
|
|
|
let attrs = sub.attributes sub tyext.tyext_attributes in
|
|
|
|
Te.mk ~attrs
|
|
|
|
~params:(List.map (type_parameter sub) tyext.tyext_params)
|
|
|
|
~priv:tyext.tyext_private
|
|
|
|
(map_loc sub tyext.tyext_txt)
|
|
|
|
(List.map (sub.extension_constructor sub) tyext.tyext_constructors)
|
|
|
|
|
|
|
|
let extension_constructor sub ext =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ext.ext_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ext.ext_attributes in
|
|
|
|
Te.constructor ~loc ~attrs
|
|
|
|
(map_loc sub ext.ext_name)
|
|
|
|
(match ext.ext_kind with
|
|
|
|
| Text_decl (args, ret) ->
|
|
|
|
Pext_decl (constructor_arguments sub args,
|
|
|
|
map_opt (sub.typ sub) ret)
|
|
|
|
| Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid)
|
|
|
|
)
|
|
|
|
|
|
|
|
let pattern sub pat =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub pat.pat_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
(* todo: fix attributes on extras *)
|
|
|
|
let attrs = sub.attributes sub pat.pat_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc =
|
|
|
|
match pat with
|
2013-09-04 08:12:37 -07:00
|
|
|
{ pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
|
|
|
|
Ppat_unpack name
|
2015-03-08 03:22:35 -07:00
|
|
|
| { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
|
|
|
|
Ppat_type (map_loc sub lid)
|
2013-03-25 07:16:07 -07:00
|
|
|
| { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ppat_constraint (sub.pat sub { pat with pat_extra=rem },
|
|
|
|
sub.typ sub ct)
|
2012-05-30 08:25:49 -07:00
|
|
|
| _ ->
|
|
|
|
match pat.pat_desc with
|
|
|
|
Tpat_any -> Ppat_any
|
|
|
|
| Tpat_var (id, name) ->
|
|
|
|
begin
|
|
|
|
match (Ident.name id).[0] with
|
|
|
|
'A'..'Z' ->
|
|
|
|
Ppat_unpack name
|
|
|
|
| _ ->
|
|
|
|
Ppat_var name
|
|
|
|
end
|
2015-03-08 03:22:37 -07:00
|
|
|
|
|
|
|
(* We transform (_ as x) in x if _ and x have the same location.
|
|
|
|
The compiler transforms (x:t) into (_ as x : t).
|
|
|
|
This avoids transforming a warning 27 into a 26.
|
|
|
|
*)
|
|
|
|
| Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
|
|
|
|
when pat_loc = pat.pat_loc ->
|
|
|
|
Ppat_var name
|
|
|
|
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tpat_alias (pat, _id, name) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ppat_alias (sub.pat sub pat, name)
|
2015-04-18 20:07:32 -07:00
|
|
|
| Tpat_constant cst -> Ppat_constant (constant cst)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tpat_tuple list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ppat_tuple (List.map (sub.pat sub) list)
|
2013-04-17 02:46:52 -07:00
|
|
|
| Tpat_construct (lid, _, args) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ppat_construct (map_loc sub lid,
|
2012-05-30 08:25:49 -07:00
|
|
|
(match args with
|
|
|
|
[] -> None
|
2015-03-08 03:22:35 -07:00
|
|
|
| [arg] -> Some (sub.pat sub arg)
|
2013-03-08 06:59:45 -08:00
|
|
|
| args ->
|
|
|
|
Some
|
2015-03-08 03:22:35 -07:00
|
|
|
(Pat.tuple ~loc
|
|
|
|
(List.map (sub.pat sub) args)
|
2013-03-08 06:59:45 -08:00
|
|
|
)
|
2013-04-17 02:46:52 -07:00
|
|
|
))
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tpat_variant (label, pato, _) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ppat_variant (label, map_opt (sub.pat sub) pato)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tpat_record (list, closed) ->
|
2012-10-24 05:03:00 -07:00
|
|
|
Ppat_record (List.map (fun (lid, _, pat) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
map_loc sub lid, sub.pat sub pat) list, closed)
|
|
|
|
| Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
|
|
|
|
| Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
|
|
|
|
| Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Pat.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let exp_extra sub (extra, loc, attrs) sexp =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub attrs in
|
2012-07-10 01:25:58 -07:00
|
|
|
let desc =
|
|
|
|
match extra with
|
2013-04-17 05:23:44 -07:00
|
|
|
Texp_coerce (cty1, cty2) ->
|
|
|
|
Pexp_coerce (sexp,
|
2015-03-08 03:22:35 -07:00
|
|
|
map_opt (sub.typ sub) cty1,
|
|
|
|
sub.typ sub cty2)
|
2013-04-17 05:23:44 -07:00
|
|
|
| Texp_constraint cty ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_constraint (sexp, sub.typ sub cty)
|
|
|
|
| Texp_open (ovf, _path, lid, _) ->
|
|
|
|
Pexp_open (ovf, map_loc sub lid, sexp)
|
|
|
|
| Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto)
|
2016-08-29 07:21:38 -07:00
|
|
|
| Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp)
|
2012-07-10 01:25:58 -07:00
|
|
|
in
|
2013-03-25 07:16:07 -07:00
|
|
|
Exp.mk ~loc ~attrs desc
|
2012-07-30 11:04:46 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let cases sub l = List.map (sub.case sub) l
|
2013-04-15 09:23:22 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let case sub {c_lhs; c_guard; c_rhs} =
|
2013-04-15 09:23:22 -07:00
|
|
|
{
|
2015-03-08 03:22:35 -07:00
|
|
|
pc_lhs = sub.pat sub c_lhs;
|
|
|
|
pc_guard = map_opt (sub.expr sub) c_guard;
|
|
|
|
pc_rhs = sub.expr sub c_rhs;
|
2013-04-15 09:23:22 -07:00
|
|
|
}
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let value_binding sub vb =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub vb.vb_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub vb.vb_attributes in
|
|
|
|
Vb.mk ~loc ~attrs
|
|
|
|
(sub.pat sub vb.vb_pat)
|
|
|
|
(sub.expr sub vb.vb_expr)
|
2013-06-03 08:14:19 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let expression sub exp =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub exp.exp_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub exp.exp_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc =
|
|
|
|
match exp.exp_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid)
|
2015-04-18 20:07:32 -07:00
|
|
|
| Texp_constant cst -> Pexp_constant (constant cst)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_let (rec_flag, list, exp) ->
|
|
|
|
Pexp_let (rec_flag,
|
2015-03-08 03:22:35 -07:00
|
|
|
List.map (sub.value_binding sub) list,
|
|
|
|
sub.expr sub exp)
|
|
|
|
|
2015-06-28 06:11:50 -07:00
|
|
|
(* Pexp_function can't have a label, so we split in 3 cases. *)
|
|
|
|
(* One case, no guard: It's a fun. *)
|
2016-10-14 01:34:50 -07:00
|
|
|
| Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}];
|
|
|
|
_ } ->
|
|
|
|
Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e)
|
2015-06-28 06:11:50 -07:00
|
|
|
(* No label: it's a function. *)
|
2016-10-14 01:34:50 -07:00
|
|
|
| Texp_function { arg_label = Nolabel; cases; _; } ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_function (sub.cases sub cases)
|
2015-06-28 06:11:50 -07:00
|
|
|
(* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *)
|
2016-10-14 01:34:50 -07:00
|
|
|
| Texp_function { arg_label = Labelled s | Optional s as label; cases;
|
|
|
|
_ } ->
|
2015-03-08 03:22:35 -07:00
|
|
|
let name = fresh_name s exp.exp_env in
|
|
|
|
Pexp_fun (label, None, Pat.var ~loc {loc;txt = name },
|
|
|
|
Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name})
|
|
|
|
(sub.cases sub cases))
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_apply (exp, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_apply (sub.expr sub exp,
|
2015-11-24 15:37:46 -08:00
|
|
|
List.fold_right (fun (label, expo) list ->
|
2012-05-30 08:25:49 -07:00
|
|
|
match expo with
|
|
|
|
None -> list
|
2015-03-08 03:22:35 -07:00
|
|
|
| Some exp -> (label, sub.expr sub exp) :: list
|
2012-05-30 08:25:49 -07:00
|
|
|
) list [])
|
Revert GPR#305 (exception patterns under or-patterns) from trunk
This week we merged several changes from Thomas Refis, to allow the
use of exception patterns under or-patterns, to write code such as
match foo x with
| None | exception Not_found -> ...
| Some -> ...
Unfortunately, I failed to properly assess the impact of this change,
and in particular to make sure that Luc Maranget had properly reviewed
this code -- any change to the pattern-matching machinery should be
reviewed by Luc.
The problem that I had not foreseen and that he would have immediately
realized is that, while adapting the pattern-matching *compiler* is
relatively easy (Thomas inserted a transformation at the right place
to separate exception patterns from the others and handle them
separately, using the staticraise construct used by the
pattern-matching compiler to avoid duplicating the
right-hand-side branch), adapting the pattern-matching warnings
machinery is both more subtle and easier to overlook (it may fail
silently and nobody notices, unlike wrong code production). This part
of the compiler is subtle and best understood by Luc, but he does not
have the time to do a proper review of those changes in the timeframe
for the 4.03 feature freeze (mid-December).
I believe the right move in this case, implemented in the present
commit, is to revert the change from trunk (this is not a feature that
we must *imperatively* have in 4.03), do a proper job of understanding
the changes, and integrate the change when we are confident it is
ready. I hope to do this in 2016, together with Luc Maranget and
Thomas Refis -- hopefully this would allow Thomas and I to be more
confident when changing the pattern-matching machinery in the future.
Revert "Merge pull request #343 from trefis/pr7083"
This reverts commit 22681b8d2a56b308673b58fba1a06781bfc6d4b6, reversing
changes made to a24e4edf0a37d78abc1046cc453b84625b1521b5.
Revert "Merge pull request #341 from trefis/or-exception"
This reverts commit f8f68bd329375fd61e33781f61deeaeec2733f4b, reversing
changes made to 1534fe8082f6edd68be3fb960606a0e2fa87a116.
Revert "Merge pull request #305 from trefis/or-exception"
This reverts commit cfeda89396c67656d61ee24509278e50cb6e36e6, reversing
changes made to 77cf36cf82e3fb87469138c5da8f4ca9774414ff.
2015-12-12 01:52:33 -08:00
|
|
|
| Texp_match (exp, cases, exn_cases, _) ->
|
|
|
|
let merged_cases = sub.cases sub cases
|
|
|
|
@ List.map
|
|
|
|
(fun c ->
|
|
|
|
let uc = sub.case sub c in
|
|
|
|
let pat = { uc.pc_lhs
|
|
|
|
with ppat_desc = Ppat_exception uc.pc_lhs }
|
|
|
|
in
|
|
|
|
{ uc with pc_lhs = pat })
|
|
|
|
exn_cases
|
|
|
|
in
|
|
|
|
Pexp_match (sub.expr sub exp, merged_cases)
|
2013-04-15 09:23:22 -07:00
|
|
|
| Texp_try (exp, cases) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_try (sub.expr sub exp, sub.cases sub cases)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_tuple list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_tuple (List.map (sub.expr sub) list)
|
2013-04-17 02:46:52 -07:00
|
|
|
| Texp_construct (lid, _, args) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_construct (map_loc sub lid,
|
2012-05-30 08:25:49 -07:00
|
|
|
(match args with
|
|
|
|
[] -> None
|
2015-03-08 03:22:35 -07:00
|
|
|
| [ arg ] -> Some (sub.expr sub arg)
|
2013-03-08 06:59:45 -08:00
|
|
|
| args ->
|
|
|
|
Some
|
2015-03-08 03:22:35 -07:00
|
|
|
(Exp.tuple ~loc (List.map (sub.expr sub) args))
|
2013-04-17 02:46:52 -07:00
|
|
|
))
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_variant (label, expo) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_variant (label, map_opt (sub.expr sub) expo)
|
2016-07-11 07:36:44 -07:00
|
|
|
| Texp_record { fields; extended_expression; _ } ->
|
2016-03-17 15:15:08 -07:00
|
|
|
let list = Array.fold_left (fun l -> function
|
2016-07-11 05:50:11 -07:00
|
|
|
| _, Kept _ -> l
|
|
|
|
| _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
|
2016-03-17 15:15:08 -07:00
|
|
|
[] fields
|
|
|
|
in
|
2016-07-11 07:36:44 -07:00
|
|
|
Pexp_record (list, map_opt (sub.expr sub) extended_expression)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Texp_field (exp, lid, _label) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_field (sub.expr sub exp, map_loc sub lid)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Texp_setfield (exp1, lid, _label, exp2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_setfield (sub.expr sub exp1, map_loc sub lid,
|
|
|
|
sub.expr sub exp2)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_array list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_array (List.map (sub.expr sub) list)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_ifthenelse (exp1, exp2, expo) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_ifthenelse (sub.expr sub exp1,
|
|
|
|
sub.expr sub exp2,
|
|
|
|
map_opt (sub.expr sub) expo)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_sequence (exp1, exp2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_while (exp1, exp2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_while (sub.expr sub exp1, sub.expr sub exp2)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Texp_for (_id, name, exp1, exp2, dir, exp3) ->
|
2012-05-30 08:25:49 -07:00
|
|
|
Pexp_for (name,
|
2015-03-08 03:22:35 -07:00
|
|
|
sub.expr sub exp1, sub.expr sub exp2,
|
|
|
|
dir, sub.expr sub exp3)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_send (exp, meth, _) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_send (sub.expr sub exp, match meth with
|
2016-08-29 07:21:38 -07:00
|
|
|
Tmeth_name name -> mkloc name loc
|
|
|
|
| Tmeth_val id -> mkloc (Ident.name id) loc)
|
2015-03-08 03:22:35 -07:00
|
|
|
| Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_instvar (_, path, name) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path})
|
2012-12-19 01:25:21 -08:00
|
|
|
| Texp_setinstvar (_, _path, lid, exp) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_setinstvar (map_loc sub lid, sub.expr sub exp)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_override (_, list) ->
|
2012-12-19 01:25:21 -08:00
|
|
|
Pexp_override (List.map (fun (_path, lid, exp) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
(map_loc sub lid, sub.expr sub exp)
|
2012-05-30 08:25:49 -07:00
|
|
|
) list)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Texp_letmodule (_id, name, mexpr, exp) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_letmodule (name, sub.module_expr sub mexpr,
|
|
|
|
sub.expr sub exp)
|
2015-11-20 01:18:49 -08:00
|
|
|
| Texp_letexception (ext, exp) ->
|
|
|
|
Pexp_letexception (sub.extension_constructor sub ext,
|
|
|
|
sub.expr sub exp)
|
2015-03-08 03:22:35 -07:00
|
|
|
| Texp_assert exp -> Pexp_assert (sub.expr sub exp)
|
|
|
|
| Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_object (cl, _) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_object (sub.class_structure sub cl)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Texp_pack (mexpr) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pexp_pack (sub.module_expr sub mexpr)
|
2015-10-15 17:13:40 -07:00
|
|
|
| Texp_unreachable ->
|
|
|
|
Pexp_unreachable
|
2015-10-30 04:37:07 -07:00
|
|
|
| Texp_extension_constructor (lid, _) ->
|
|
|
|
Pexp_extension ({ txt = "ocaml.extension_constructor"; loc },
|
|
|
|
PStr [ Str.eval ~loc
|
|
|
|
(Exp.construct ~loc (map_loc sub lid) None)
|
|
|
|
])
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
List.fold_right (exp_extra sub) exp.exp_extra
|
|
|
|
(Exp.mk ~loc ~attrs desc)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let package_type sub pack =
|
|
|
|
(map_loc sub pack.pack_txt,
|
2012-05-30 08:25:49 -07:00
|
|
|
List.map (fun (s, ct) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
(s, sub.typ sub ct)) pack.pack_fields)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let module_type_declaration sub mtd =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub mtd.mtd_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub mtd.mtd_attributes in
|
|
|
|
Mtd.mk ~loc ~attrs
|
|
|
|
?typ:(map_opt (sub.module_type sub) mtd.mtd_type)
|
|
|
|
(map_loc sub mtd.mtd_name)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let signature sub sg =
|
|
|
|
List.map (sub.signature_item sub) sg.sig_items
|
|
|
|
|
|
|
|
let signature_item sub item =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub item.sig_loc in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc =
|
|
|
|
match item.sig_desc with
|
2013-03-25 11:04:40 -07:00
|
|
|
Tsig_value v ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_value (sub.value_description sub v)
|
2015-03-13 04:09:08 -07:00
|
|
|
| Tsig_type (rec_flag, list) ->
|
|
|
|
Psig_type (rec_flag, List.map (sub.type_declaration sub) list)
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tsig_typext tyext ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_typext (sub.type_extension sub tyext)
|
2014-05-04 16:08:45 -07:00
|
|
|
| Tsig_exception ext ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_exception (sub.extension_constructor sub ext)
|
2013-03-25 10:47:28 -07:00
|
|
|
| Tsig_module md ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_module (sub.module_declaration sub md)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tsig_recmodule list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_recmodule (List.map (sub.module_declaration sub) list)
|
2013-03-25 10:47:28 -07:00
|
|
|
| Tsig_modtype mtd ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_modtype (sub.module_type_declaration sub mtd)
|
2014-04-15 04:26:00 -07:00
|
|
|
| Tsig_open od ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_open (sub.open_description sub od)
|
2014-04-15 04:26:00 -07:00
|
|
|
| Tsig_include incl ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_include (sub.include_description sub incl)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tsig_class list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_class (List.map (sub.class_description sub) list)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tsig_class_type list ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Psig_class_type (List.map (sub.class_type_declaration sub) list)
|
2013-03-25 07:16:07 -07:00
|
|
|
| Tsig_attribute x ->
|
|
|
|
Psig_attribute x
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Sig.mk ~loc desc
|
|
|
|
|
|
|
|
let module_declaration sub md =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub md.md_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub md.md_attributes in
|
|
|
|
Md.mk ~loc ~attrs
|
|
|
|
(map_loc sub md.md_name)
|
|
|
|
(sub.module_type sub md.md_type)
|
|
|
|
|
|
|
|
let include_infos f sub incl =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub incl.incl_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub incl.incl_attributes in
|
|
|
|
Incl.mk ~loc ~attrs
|
|
|
|
(f sub incl.incl_mod)
|
|
|
|
|
|
|
|
let include_declaration sub = include_infos sub.module_expr sub
|
|
|
|
let include_description sub = include_infos sub.module_type sub
|
|
|
|
|
|
|
|
let class_infos f sub ci =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ci.ci_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ci.ci_attributes in
|
|
|
|
Ci.mk ~loc ~attrs
|
|
|
|
~virt:ci.ci_virt
|
|
|
|
~params:(List.map (type_parameter sub) ci.ci_params)
|
|
|
|
(map_loc sub ci.ci_id_name)
|
|
|
|
(f sub ci.ci_expr)
|
|
|
|
|
|
|
|
let class_declaration sub = class_infos sub.class_expr sub
|
|
|
|
let class_description sub = class_infos sub.class_type sub
|
|
|
|
let class_type_declaration sub = class_infos sub.class_type sub
|
|
|
|
|
|
|
|
let module_type sub mty =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub mty.mty_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub mty.mty_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match mty.mty_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid)
|
|
|
|
| Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid)
|
|
|
|
| Tmty_signature sg -> Pmty_signature (sub.signature sub sg)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tmty_functor (_id, name, mtype1, mtype2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pmty_functor (name, map_opt (sub.module_type sub) mtype1,
|
|
|
|
sub.module_type sub mtype2)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tmty_with (mtype, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pmty_with (sub.module_type sub mtype,
|
|
|
|
List.map (sub.with_constraint sub) list)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tmty_typeof mexpr ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pmty_typeof (sub.module_expr sub mexpr)
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Mty.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let with_constraint sub (_path, lid, cstr) =
|
2012-05-30 08:25:49 -07:00
|
|
|
match cstr with
|
2015-03-08 03:22:35 -07:00
|
|
|
| Twith_type decl ->
|
|
|
|
Pwith_type (map_loc sub lid, sub.type_declaration sub decl)
|
|
|
|
| Twith_module (_path, lid2) ->
|
|
|
|
Pwith_module (map_loc sub lid, map_loc sub lid2)
|
2016-08-29 21:16:28 -07:00
|
|
|
| Twith_typesubst decl ->
|
|
|
|
Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl)
|
2013-04-16 03:47:45 -07:00
|
|
|
| Twith_modsubst (_path, lid2) ->
|
2016-09-04 11:06:50 -07:00
|
|
|
Pwith_modsubst (map_loc sub lid, map_loc sub lid2)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let module_expr sub mexpr =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub mexpr.mod_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub mexpr.mod_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
match mexpr.mod_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Tmod_constraint (m, _, Tmodtype_implicit, _ ) ->
|
|
|
|
sub.module_expr sub m
|
|
|
|
| _ ->
|
|
|
|
let desc = match mexpr.mod_desc with
|
|
|
|
Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid)
|
|
|
|
| Tmod_structure st -> Pmod_structure (sub.structure sub st)
|
|
|
|
| Tmod_functor (_id, name, mtype, mexpr) ->
|
|
|
|
Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype,
|
|
|
|
sub.module_expr sub mexpr)
|
|
|
|
| Tmod_apply (mexp1, mexp2, _) ->
|
|
|
|
Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2)
|
|
|
|
| Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) ->
|
|
|
|
Pmod_constraint (sub.module_expr sub mexpr,
|
|
|
|
sub.module_type sub mtype)
|
|
|
|
| Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) ->
|
|
|
|
assert false
|
|
|
|
| Tmod_unpack (exp, _pack) ->
|
|
|
|
Pmod_unpack (sub.expr sub exp)
|
|
|
|
(* TODO , sub.package_type sub pack) *)
|
|
|
|
in
|
|
|
|
Mod.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_expr sub cexpr =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub cexpr.cl_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub cexpr.cl_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match cexpr.cl_desc with
|
2013-09-04 08:12:37 -07:00
|
|
|
| Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ },
|
|
|
|
None, _, _, _ ) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcl_constr (map_loc sub lid,
|
|
|
|
List.map (sub.typ sub) tyl)
|
|
|
|
| Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tcl_fun (label, pat, _pv, cl, _partial) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
|
|
|
| Tcl_apply (cl, args) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcl_apply (sub.class_expr sub cl,
|
2015-11-24 15:37:46 -08:00
|
|
|
List.fold_right (fun (label, expo) list ->
|
2012-05-30 08:25:49 -07:00
|
|
|
match expo with
|
|
|
|
None -> list
|
2015-03-08 03:22:35 -07:00
|
|
|
| Some exp -> (label, sub.expr sub exp) :: list
|
2012-05-30 08:25:49 -07:00
|
|
|
) args [])
|
|
|
|
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tcl_let (rec_flat, bindings, _ivars, cl) ->
|
2012-05-30 08:25:49 -07:00
|
|
|
Pcl_let (rec_flat,
|
2015-03-08 03:22:35 -07:00
|
|
|
List.map (sub.value_binding sub) bindings,
|
|
|
|
sub.class_expr sub cl)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2017-07-19 23:17:30 -07:00
|
|
|
| Tcl_open (ovf, _p, lid, _env, e) ->
|
|
|
|
Pcl_open (ovf, lid, sub.class_expr sub e)
|
|
|
|
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tcl_ident _ -> assert false
|
|
|
|
| Tcl_constraint (_, None, _, _, _) -> assert false
|
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Cl.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_type sub ct =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ct.cltyp_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ct.cltyp_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match ct.cltyp_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Tcty_constr (_path, lid, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list)
|
2013-04-16 01:59:09 -07:00
|
|
|
| Tcty_arrow (label, ct, cl) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl)
|
2017-07-19 23:17:30 -07:00
|
|
|
| Tcty_open (ovf, _p, lid, _env, e) ->
|
|
|
|
Pcty_open (ovf, lid, sub.class_type sub e)
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Cty.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_signature sub cs =
|
2012-05-30 08:25:49 -07:00
|
|
|
{
|
2015-03-08 03:22:35 -07:00
|
|
|
pcsig_self = sub.typ sub cs.csig_self;
|
|
|
|
pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields;
|
2012-05-30 08:25:49 -07:00
|
|
|
}
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_type_field sub ctf =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ctf.ctf_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ctf.ctf_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match ctf.ctf_desc with
|
2015-03-08 03:22:35 -07:00
|
|
|
Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Tctf_val (s, mut, virt, ct) ->
|
2016-08-29 07:21:38 -07:00
|
|
|
Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct)
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tctf_method (s, priv, virt, ct) ->
|
2016-08-29 07:21:38 -07:00
|
|
|
Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct)
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tctf_constraint (ct1, ct2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2)
|
2014-05-04 13:42:34 -07:00
|
|
|
| Tctf_attribute x -> Pctf_attribute x
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Ctf.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let core_type sub ct =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub ct.ctyp_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub ct.ctyp_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match ct.ctyp_desc with
|
|
|
|
Ttyp_any -> Ptyp_any
|
|
|
|
| Ttyp_var s -> Ptyp_var s
|
|
|
|
| Ttyp_arrow (label, ct1, ct2) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2)
|
|
|
|
| Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list)
|
2012-12-19 01:25:21 -08:00
|
|
|
| Ttyp_constr (_path, lid, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ptyp_constr (map_loc sub lid,
|
|
|
|
List.map (sub.typ sub) list)
|
2013-04-09 06:29:00 -07:00
|
|
|
| Ttyp_object (list, o) ->
|
2014-05-05 04:21:45 -07:00
|
|
|
Ptyp_object
|
2017-03-09 20:46:48 -08:00
|
|
|
(List.map (sub.object_field sub) list, o)
|
2013-04-16 05:17:17 -07:00
|
|
|
| Ttyp_class (_path, lid, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Ttyp_alias (ct, s) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ptyp_alias (sub.typ sub ct, s)
|
2012-05-30 08:25:49 -07:00
|
|
|
| Ttyp_variant (list, bool, labels) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Ptyp_variant (List.map (sub.row_field sub) list, bool, labels)
|
2016-08-29 07:21:38 -07:00
|
|
|
| Ttyp_poly (list, ct) ->
|
|
|
|
let list = List.map (fun v -> mkloc v loc) list in
|
|
|
|
Ptyp_poly (list, sub.typ sub ct)
|
2015-03-08 03:22:35 -07:00
|
|
|
| Ttyp_package pack -> Ptyp_package (sub.package_type sub pack)
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Typ.mk ~loc ~attrs desc
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_structure sub cs =
|
2014-08-22 06:45:02 -07:00
|
|
|
let rec remove_self = function
|
2015-03-08 03:22:35 -07:00
|
|
|
| { pat_desc = Tpat_alias (p, id, _s) }
|
|
|
|
when string_is_prefix "selfpat-" id.Ident.name ->
|
2014-08-22 06:45:02 -07:00
|
|
|
remove_self p
|
|
|
|
| p -> p
|
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
{ pcstr_self = sub.pat sub (remove_self cs.cstr_self);
|
|
|
|
pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields;
|
2012-05-30 08:25:49 -07:00
|
|
|
}
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let row_field sub rf =
|
2012-05-30 08:25:49 -07:00
|
|
|
match rf with
|
2014-04-30 01:19:55 -07:00
|
|
|
Ttag (label, attrs, bool, list) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list)
|
|
|
|
| Tinherit ct -> Rinherit (sub.typ sub ct)
|
2012-05-30 08:25:49 -07:00
|
|
|
|
2017-03-09 20:46:48 -08:00
|
|
|
let object_field sub ofield =
|
|
|
|
match ofield with
|
|
|
|
OTtag (label, attrs, ct) ->
|
|
|
|
Otag (label, sub.attributes sub attrs, sub.typ sub ct)
|
|
|
|
| OTinherit ct -> Oinherit (sub.typ sub ct)
|
|
|
|
|
2014-08-22 06:45:02 -07:00
|
|
|
and is_self_pat = function
|
|
|
|
| { pat_desc = Tpat_alias(_pat, id, _) } ->
|
|
|
|
string_is_prefix "self-" (Ident.name id)
|
|
|
|
| _ -> false
|
|
|
|
|
2015-03-08 03:22:35 -07:00
|
|
|
let class_field sub cf =
|
2017-08-29 07:14:50 -07:00
|
|
|
let loc = sub.location sub cf.cf_loc in
|
2015-03-08 03:22:35 -07:00
|
|
|
let attrs = sub.attributes sub cf.cf_attributes in
|
2012-05-30 08:25:49 -07:00
|
|
|
let desc = match cf.cf_desc with
|
2013-04-10 04:17:41 -07:00
|
|
|
Tcf_inherit (ovf, cl, super, _vals, _meths) ->
|
2016-08-29 07:21:38 -07:00
|
|
|
Pcf_inherit (ovf, sub.class_expr sub cl,
|
|
|
|
map_opt (fun v -> mkloc v loc) super)
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_constraint (cty, cty') ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_constraint (sub.typ sub cty, sub.typ sub cty')
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_val (lab, mut, _, Tcfk_virtual cty, _) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty))
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp))
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_method (lab, priv, Tcfk_virtual cty) ->
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty))
|
2013-04-10 04:17:41 -07:00
|
|
|
| Tcf_method (lab, priv, Tcfk_concrete (o, exp)) ->
|
2014-08-22 06:45:02 -07:00
|
|
|
let remove_fun_self = function
|
2016-10-14 01:34:50 -07:00
|
|
|
| { exp_desc =
|
|
|
|
Texp_function { arg_label = Nolabel; cases = [case]; _ } }
|
2014-12-22 00:45:55 -08:00
|
|
|
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
|
2014-08-22 06:45:02 -07:00
|
|
|
| e -> e
|
|
|
|
in
|
|
|
|
let exp = remove_fun_self exp in
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp))
|
|
|
|
| Tcf_initializer exp ->
|
2014-08-22 06:45:02 -07:00
|
|
|
let remove_fun_self = function
|
2016-10-14 01:34:50 -07:00
|
|
|
| { exp_desc =
|
|
|
|
Texp_function { arg_label = Nolabel; cases = [case]; _ } }
|
2014-12-22 00:45:55 -08:00
|
|
|
when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs
|
2014-08-22 06:45:02 -07:00
|
|
|
| e -> e
|
|
|
|
in
|
|
|
|
let exp = remove_fun_self exp in
|
2015-03-08 03:22:35 -07:00
|
|
|
Pcf_initializer (sub.expr sub exp)
|
2014-05-04 13:42:34 -07:00
|
|
|
| Tcf_attribute x -> Pcf_attribute x
|
2012-05-30 08:25:49 -07:00
|
|
|
in
|
2015-03-08 03:22:35 -07:00
|
|
|
Cf.mk ~loc ~attrs desc
|
|
|
|
|
2016-03-09 02:40:16 -08:00
|
|
|
let location _sub l = l
|
2015-03-08 03:22:35 -07:00
|
|
|
|
|
|
|
let default_mapper =
|
|
|
|
{
|
|
|
|
attribute = attribute ;
|
|
|
|
attributes = attributes ;
|
|
|
|
structure = structure;
|
|
|
|
structure_item = structure_item;
|
|
|
|
module_expr = module_expr;
|
|
|
|
signature = signature;
|
|
|
|
signature_item = signature_item;
|
|
|
|
module_type = module_type;
|
|
|
|
with_constraint = with_constraint;
|
|
|
|
class_declaration = class_declaration;
|
|
|
|
class_expr = class_expr;
|
|
|
|
class_field = class_field;
|
|
|
|
class_structure = class_structure;
|
|
|
|
class_type = class_type;
|
|
|
|
class_type_field = class_type_field;
|
|
|
|
class_signature = class_signature;
|
|
|
|
class_type_declaration = class_type_declaration;
|
|
|
|
class_description = class_description;
|
|
|
|
type_declaration = type_declaration;
|
|
|
|
type_kind = type_kind;
|
|
|
|
typ = core_type;
|
|
|
|
type_extension = type_extension;
|
|
|
|
extension_constructor = extension_constructor;
|
|
|
|
value_description = value_description;
|
|
|
|
pat = pattern;
|
|
|
|
expr = expression;
|
|
|
|
module_declaration = module_declaration;
|
|
|
|
module_type_declaration = module_type_declaration;
|
|
|
|
module_binding = module_binding;
|
|
|
|
package_type = package_type ;
|
|
|
|
open_description = open_description;
|
|
|
|
include_description = include_description;
|
|
|
|
include_declaration = include_declaration;
|
|
|
|
value_binding = value_binding;
|
|
|
|
constructor_declaration = constructor_declaration;
|
|
|
|
label_declaration = label_declaration;
|
|
|
|
cases = cases;
|
|
|
|
case = case;
|
|
|
|
location = location;
|
|
|
|
row_field = row_field ;
|
2017-03-09 20:46:48 -08:00
|
|
|
object_field = object_field ;
|
2015-03-08 03:22:35 -07:00
|
|
|
}
|
|
|
|
|
|
|
|
let untype_structure ?(mapper=default_mapper) structure =
|
|
|
|
mapper.structure mapper structure
|
|
|
|
|
|
|
|
let untype_signature ?(mapper=default_mapper) signature =
|
|
|
|
mapper.signature mapper signature
|