Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Better representation of with-constraints. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13540 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2013-04-16 10:47:45 +00:00
parent 4f758291bc
commit 3fe10139ab
15 changed files with 112 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

@ -446,7 +446,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct
value mkwithtyp pwith_type loc id_tpl ct =
let (id, tpl) = type_parameters_and_type_name id_tpl [] in
let (kind, priv, ct) = opt_private_ctyp ct in
(id, pwith_type
pwith_type id
{ ptype_name = Camlp4_import.Location.mkloc (Camlp4_import.Longident.last id.txt) id.loc;
ptype_params = tpl; ptype_cstrs = [];
ptype_kind = kind;
@ -454,19 +454,24 @@ module Make (Ast : Sig.Camlp4Ast) = struct
ptype_manifest = Some ct;
ptype_loc = mkloc loc;
ptype_attributes = [];
});
};
value rec mkwithc wc acc =
match wc with
[ <:with_constr<>> -> acc
| <:with_constr@loc< type $id_tpl$ = $ct$ >> ->
[mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct :: acc]
[mkwithtyp (fun lid x -> Pwith_type lid x) loc id_tpl ct :: acc]
| <:with_constr< module $i1$ = $i2$ >> ->
[(long_uident i1, Pwith_module (long_uident i2)) :: acc]
[(Pwith_module (long_uident i1) (long_uident i2)) :: acc]
| <:with_constr@loc< type $id_tpl$ := $ct$ >> ->
[mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct :: acc]
| <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) ->
[(long_uident i1, Pwith_modsubst (long_uident i2)) :: acc]
[mkwithtyp (fun _ x -> Pwith_typesubst x) loc id_tpl ct :: acc]
| <:with_constr@loc< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) ->
match long_uident i1 with
[ {txt=Lident s; loc} ->
[(Pwith_modsubst {txt=s;loc} (long_uident i2)) ::
acc]
| _ -> error loc "bad 'with module :=' constraint"
]
| <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc)
| <:with_constr@loc< $anti:_$ >> ->
error loc "bad with constraint (antiquotation)" ];

21
camlp4/boot/Camlp4.ml
View File

@ -14626,8 +14626,7 @@ module Struct =
let (id, tpl) = type_parameters_and_type_name id_tpl [] in
let (kind, priv, ct) = opt_private_ctyp ct
in
(id,
(pwith_type
pwith_type id
{
ptype_name = Camlp4_import.Location.mkloc (Camlp4_import.Longident.last id.txt) id.loc;
ptype_params = tpl;
@ -14637,21 +14636,25 @@ module Struct =
ptype_manifest = Some ct;
ptype_loc = mkloc loc;
ptype_attributes = [];
}))
}
let rec mkwithc wc acc =
match wc with
| Ast.WcNil _ -> acc
| Ast.WcTyp (loc, id_tpl, ct) ->
(mkwithtyp (fun x -> Pwith_type x) loc id_tpl ct) :: acc
(mkwithtyp (fun lid x -> Pwith_type (lid, x)) loc id_tpl ct) :: acc
| Ast.WcMod (_, i1, i2) ->
((long_uident i1), (Pwith_module (long_uident i2))) :: acc
(Pwith_module (long_uident i1, long_uident i2)) :: acc
| Ast.WcTyS (loc, id_tpl, ct) ->
(mkwithtyp (fun x -> Pwith_typesubst x) loc id_tpl ct) ::
acc
| Ast.WcMoS (_, i1, i2) ->
((long_uident i1), (Pwith_modsubst (long_uident i2))) ::
(mkwithtyp (fun _ x -> Pwith_typesubst x) loc id_tpl ct) ::
acc
| Ast.WcMoS (loc, i1, i2) ->
begin match long_uident i1 with
| {txt=Lident s; loc} ->
(Pwith_modsubst ({txt=s;loc},long_uident i2)) ::
acc
| _ -> error loc "bad 'with module :=' constraint"
end
| Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc)
| Ast.WcAnt (loc, _) ->
error loc "bad with constraint (antiquotation)"

10
experimental/frisch/extension_points.txt
View File

@ -427,6 +427,16 @@ Rationale:
It was only used for error messages, and we get better location using
the location of each parameter variable.
--- More faithful representation of "with constraint"
All kinds of "with constraints" used to be represented together with a
Longident.t denoting the constrained identifier. Now, each constraint
keeps its own constrainted identifier, which allows us to express more
invariants in the Parsetree (such as: := constraints cannot be on qualified
identifiers). Also, we avoid mixing in a single Longident.t identifier
which can be LIDENT or UIDENT.
=== More TODOs
- Adapt pprintast to print attributes and extension nodes.

7
ocamldoc/odoc_sig.ml
View File

@ -257,11 +257,12 @@ module Analyser =
Odoc_type.Type_record (List.map f l)
let erased_names_of_constraints constraints acc =
List.fold_right (fun (longident, constraint_) acc ->
List.fold_right (fun constraint_ acc ->
match constraint_ with
| Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc
| Parsetree.Pwith_typesubst _ | Parsetree.Pwith_modsubst _ ->
Name.Set.add (Name.from_longident longident.txt) acc)
| Parsetree.Pwith_typesubst {Parsetree.ptype_name=s}
| Parsetree.Pwith_modsubst (s, _) ->
Name.Set.add s.txt acc)
constraints acc
let filter_out_erased_items_from_signature erased signature =

2
otherlibs/labltk/browser/searchpos.ml
View File

@ -235,7 +235,7 @@ and search_pos_module m ~pos ~env =
search_pos_module m ~pos ~env;
List.iter l ~f:
begin function
_, Pwith_type t -> search_pos_type_decl t ~pos ~env
Pwith_type (_, t) -> search_pos_type_decl t ~pos ~env
| _ -> ()
end
| Pmty_typeof md ->

2
parsing/ast_helper.mli
View File

@ -116,7 +116,7 @@ module Mty:
val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type
val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type
val functor_: ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_type -> module_type
val with_: ?loc:loc -> ?attrs:attrs -> module_type -> (lid * with_constraint) list -> module_type
val with_: ?loc:loc -> ?attrs:attrs -> module_type -> with_constraint list -> module_type
val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type
val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type
end

11
parsing/ast_mapper.ml
View File

@ -115,15 +115,18 @@ module MT = struct
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
| Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg)
| Pmty_functor (s, mt1, mt2) -> functor_ ~loc ~attrs (map_loc sub s) (sub # module_type mt1) (sub # module_type mt2)
| Pmty_with (mt, l) -> with_ ~loc ~attrs (sub # module_type mt) (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l)
| Pmty_with (mt, l) -> with_ ~loc ~attrs (sub # module_type mt) (List.map (sub # with_constraint) l)
| Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me)
| Pmty_extension x -> extension ~loc ~attrs (sub # extension x)
let map_with_constraint sub = function
| Pwith_type d -> Pwith_type (sub # type_declaration d)
| Pwith_module s -> Pwith_module (map_loc sub s)
| Pwith_type (lid, d) ->
Pwith_type (map_loc sub lid, sub # type_declaration d)
| Pwith_module (lid, lid2) ->
Pwith_module (map_loc sub lid, map_loc sub lid2)
| Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
| Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
| Pwith_modsubst (s, lid) ->
Pwith_modsubst (map_loc sub s, map_loc sub lid)
let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
let open Sig in

17
parsing/parser.mly
View File

@ -1554,7 +1554,8 @@ with_constraints:
;
with_constraint:
TYPE type_parameters label_longident with_type_binder core_type constraints
{ (mkrhs $3 3, Pwith_type
{ Pwith_type
(mkrhs $3 3,
(Type.mk (mkrhs (Longident.last $3) 3)
~params:(List.map (fun (x, v) -> Some x, v) $2)
~cstrs:(List.rev $6)
@ -1564,15 +1565,15 @@ with_constraint:
/* used label_longident instead of type_longident to disallow
functor applications in type path */
| TYPE type_parameters label COLONEQUAL core_type
{ (mkrhs (Lident $3) 3, Pwith_typesubst
(Type.mk (mkrhs $3 3)
~params:(List.map (fun (x, v) -> Some x, v) $2)
~manifest:$5
~loc:(symbol_rloc()))) }
{ Pwith_typesubst
(Type.mk (mkrhs $3 3)
~params:(List.map (fun (x, v) -> Some x, v) $2)
~manifest:$5
~loc:(symbol_rloc())) }
| MODULE mod_longident EQUAL mod_ext_longident
{ (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
{ Pwith_module (mkrhs $2 2, mkrhs $4 4) }
| MODULE UIDENT COLONEQUAL mod_ext_longident
{ (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
{ Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) }
;
with_type_binder:
EQUAL { Public }

15
parsing/parsetree.mli
View File

@ -564,7 +564,7 @@ and module_type_desc =
(* sig ... end *)
| Pmty_functor of string loc * module_type * module_type
(* functor(X : MT1) -> MT2 *)
| Pmty_with of module_type * (Longident.t loc * with_constraint) list
| Pmty_with of module_type * with_constraint list
(* MT with ... *)
| Pmty_typeof of module_expr
(* module type of ME *)
@ -627,10 +627,17 @@ and module_type_declaration =
(* S = MT *)
and with_constraint =
| Pwith_type of type_declaration
| Pwith_module of Longident.t loc
| Pwith_type of Longident.t loc * type_declaration
(* with type X.t = ...
Note: the last component of the longident must match
the name of the type_declaration. *)
| Pwith_module of Longident.t loc * Longident.t loc
(* with module X.Y = Z *)
| Pwith_typesubst of type_declaration
| Pwith_modsubst of Longident.t loc
(* with type t := ... *)
| Pwith_modsubst of string loc * Longident.t loc
(* with module X := Z *)
(* Value expressions for the module language *)

17
parsing/pprintast.ml
View File

@ -862,27 +862,26 @@ class printer ()= object(self:'self)
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
self#module_type mt1 self#module_type mt2
| Pmty_with (mt, l) ->
let longident_x_with_constraint f (li, wc) =
match wc with
| Pwith_type ({ptype_params= ls ;_} as td) ->
let with_constraint f = function
| Pwith_type (li, ({ptype_params= ls ;_} as td)) ->
let ls = List.map fst ls in
pp f "type@ %a %a =@ %a"
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li self#type_declaration td
| Pwith_module (li2) ->
| Pwith_module (li, li2) ->
pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
| Pwith_typesubst ({ptype_params=ls;_} as td) ->
let ls = List.map fst ls in
pp f "type@ %a %a :=@ %a"
pp f "type@ %a %s :=@ %a"
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li
ls td.ptype_name.txt
self#type_declaration td
| Pwith_modsubst (li2) ->
pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
| Pwith_modsubst (s, li2) ->
pp f "module %s :=@ %a" s.txt self#longident_loc li2 in
(match l with
| [] -> pp f "@[<hov2>%a@]" self#module_type mt
| _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
self#module_type mt (self#list with_constraint ~sep:"@ and@ ") l )
| Pmty_typeof me ->
pp f "@[<hov2>module@ type@ of@ %a@]"
self#module_expr me

20
parsing/printast.ml
View File

@ -566,7 +566,7 @@ and module_type i ppf x =
| Pmty_with (mt, l) ->
line i ppf "Pmty_with\n";
module_type i ppf mt;
list i longident_x_with_constraint ppf l;
list i with_constraint ppf l;
| Pmty_typeof m ->
line i ppf "Pmty_typeof\n";
module_expr i ppf m;
@ -627,14 +627,20 @@ and modtype_declaration i ppf = function
and with_constraint i ppf x =
match x with
| Pwith_type (td) ->
line i ppf "Pwith_type\n";
| Pwith_type (lid, td) ->
line i ppf "Pwith_type %a\n" fmt_longident_loc lid;
type_declaration (i+1) ppf td;
| Pwith_typesubst (td) ->
line i ppf "Pwith_typesubst\n";
type_declaration (i+1) ppf td;
| Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
| Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
| Pwith_module (lid1, lid2) ->
line i ppf "Pwith_module %a = %a\n"
fmt_longident_loc lid1
fmt_longident_loc lid2;
| Pwith_modsubst (s, li) ->
line i ppf "Pwith_modsubst %a = %a\n"
fmt_string_loc s
fmt_longident_loc li;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
@ -733,10 +739,6 @@ and module_binding i ppf x =
attributes i ppf x.pmb_attributes;
module_expr (i+1) ppf x.pmb_expr
and longident_x_with_constraint i ppf (li, wc) =
line i ppf "%a\n" fmt_longident_loc li;
with_constraint (i+1) ppf wc;
and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
line i ppf "<constraint> %a\n" fmt_location l;
core_type (i+1) ppf ct1;

10
tools/depend.ml
View File

@ -200,10 +200,12 @@ and add_modtype bv mty =
| Pmty_with(mty, cstrl) ->
add_modtype bv mty;
List.iter
(function (_, Pwith_type td) -> add_type_declaration bv td
| (_, Pwith_module (lid)) -> addmodule bv lid
| (_, Pwith_typesubst td) -> add_type_declaration bv td
| (_, Pwith_modsubst (lid)) -> addmodule bv lid)
(function
| Pwith_type (_, td) -> add_type_declaration bv td
| Pwith_module (_, lid) -> addmodule bv lid
| Pwith_typesubst td -> add_type_declaration bv td
| Pwith_modsubst (_, lid) -> addmodule bv lid
)
cstrl
| Pmty_typeof m -> add_module bv m
| Pmty_extension _ -> ()

9
tools/untypeast.ml
View File

@ -374,7 +374,7 @@ and untype_module_type mty =
| Tmty_with (mtype, list) ->
Pmty_with (untype_module_type mtype,
List.map (fun (_path, lid, withc) ->
lid, untype_with_constraint lid withc
untype_with_constraint lid withc
) list)
| Tmty_typeof mexpr ->
Pmty_typeof (untype_module_expr mexpr)
@ -383,10 +383,11 @@ and untype_module_type mty =
and untype_with_constraint lid cstr =
match cstr with
Twith_type decl -> Pwith_type (untype_type_declaration decl)
| Twith_module (_path, lid) -> Pwith_module (lid)
Twith_type decl -> Pwith_type (lid, untype_type_declaration decl)
| Twith_module (_path, lid2) -> Pwith_module (lid, lid2)
| Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl)
| Twith_modsubst (_path, lid) -> Pwith_modsubst (lid)
| Twith_modsubst (_path, lid2) ->
Pwith_modsubst ({loc = lid.loc; txt=Longident.last lid.txt}, lid2)
and untype_module_expr mexpr =
match mexpr.mod_desc with

22
typing/typemod.ml
View File

@ -114,14 +114,20 @@ let sig_item desc typ env loc = {
Typedtree.sig_desc = desc; sig_loc = loc; sig_env = env
}
let merge_constraint initial_env loc sg lid constr =
let merge_constraint initial_env loc sg constr =
let lid =
match constr with
| Pwith_type (lid, _) | Pwith_module (lid, _) -> lid
| Pwith_typesubst {ptype_name=s} | Pwith_modsubst (s, _) ->
{loc = s.loc; txt=Lident s.txt}
in
let real_id = ref None in
let rec merge env sg namelist row_id =
match (sg, namelist, constr) with
([], _, _) ->
raise(Error(loc, env, With_no_component lid.txt))
| (Sig_type(id, decl, rs) :: rem, [s],
Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)))
when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
let decl_row =
{ type_params =
@ -151,7 +157,7 @@ let merge_constraint initial_env loc sg lid constr =
let rs' = if rs = Trec_first then Trec_not else rs in
(Pident id, lid, Twith_type tdecl),
Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem
| (Sig_type(id, decl, rs) :: rem , [s], Pwith_type sdecl)
| (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl))
when Ident.name id = s ->
let tdecl =
Typedecl.transl_with_constraint initial_env id None decl sdecl in
@ -171,14 +177,14 @@ let merge_constraint initial_env loc sg lid constr =
real_id := Some id;
(Pident id, lid, Twith_typesubst tdecl),
make_next_first rs rem
| (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (lid))
| (Sig_module(id, mty, rs) :: rem, [s], Pwith_module (_, lid))
when Ident.name id = s ->
let (path, mty') = Typetexp.find_module initial_env loc lid.txt in
let newmty = Mtype.strengthen env mty' path in
ignore(Includemod.modtypes env newmty mty);
(Pident id, lid, Twith_module (path, lid)),
Sig_module(id, newmty, rs) :: rem
| (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (lid))
| (Sig_module(id, mty, rs) :: rem, [s], Pwith_modsubst (_, lid))
when Ident.name id = s ->
let (path, mty') = Typetexp.find_module initial_env loc lid.txt in
let newmty = Mtype.strengthen env mty' path in
@ -228,7 +234,7 @@ let merge_constraint initial_env loc sg lid constr =
in
let sub = Subst.add_type id path Subst.identity in
Subst.signature sub sg
| [s], Pwith_modsubst (lid) ->
| [s], Pwith_modsubst (_, lid) ->
let id =
match !real_id with None -> assert false | Some id -> id in
let (path, _) = Typetexp.find_module initial_env loc lid.txt in
@ -438,8 +444,8 @@ let rec transl_modtype env smty =
let init_sg = extract_sig env sbody.pmty_loc body.mty_type in
let (tcstrs, final_sg) =
List.fold_left
(fun (tcstrs,sg) (lid, sdecl) ->
let (tcstr, sg) = merge_constraint env smty.pmty_loc sg lid sdecl
(fun (tcstrs,sg) sdecl ->
let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl
in
(tcstr :: tcstrs, sg)
)

2
typing/typetexp.ml
View File

@ -144,7 +144,7 @@ let create_package_mty fake loc env (p, l) =
ptype_manifest = if fake then None else Some t;
ptype_attributes = [];
ptype_loc = loc} in
Ast_helper.Mty.mk ~loc (Pmty_with (mty, [ { txt = s.txt; loc }, Pwith_type d ]))
Ast_helper.Mty.mk ~loc (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ]))
)
(Ast_helper.Mty.mk ~loc (Pmty_ident p))
l