[Pkg-ocaml-maint-commits] [SCM] fieldslib packaging branch, upstream, updated. upstream/107.01-24-gf6cfb28
Stephane Glondu
steph at glondu.net
Sun Jun 23 21:06:20 UTC 2013
The following commit has been merged in the upstream branch:
commit 4dbb6b79d18cf8a5d0f4be2be1fd48d202fae941
Author: Stephane Glondu <steph at glondu.net>
Date: Sun Jun 23 22:12:53 2013 +0200
Imported Upstream version 109.14.00
diff --git a/_oasis b/_oasis
index fd970f9..6849781 100644
--- a/_oasis
+++ b/_oasis
@@ -2,7 +2,7 @@ OASISFormat: 0.3
OCamlVersion: >= 4.00.0
FindlibVersion: >= 1.3.2
Name: fieldslib
-Version: 109.13.00
+Version: 109.14.00
Synopsis: OCaml record fields as first class values.
Authors: Jane Street Capital LLC <opensource at janestreet.com>
Copyrights: (C) 2009-2013 Jane Street Capital LLC <opensource at janestreet.com>
diff --git a/lib/META b/lib/META
index 130e8dc..c67cde9 100644
--- a/lib/META
+++ b/lib/META
@@ -1,6 +1,6 @@
# OASIS_START
-# DO NOT EDIT (digest: 2bb4b08f801dcc4338744a6ecb3544db)
-version = "109.13.00"
+# DO NOT EDIT (digest: ba64376e436524522f451e9c335ef6be)
+version = "109.14.00"
description = "OCaml record fields as first class values."
archive(byte) = "fieldslib.cma"
archive(byte, plugin) = "fieldslib.cma"
@@ -8,7 +8,7 @@ archive(native) = "fieldslib.cmxa"
archive(native, plugin) = "fieldslib.cmxs"
exists_if = "fieldslib.cma"
package "syntax" (
- version = "109.13.00"
+ version = "109.14.00"
description = "Syntax extension for Fieldslib"
requires = "camlp4 type_conv fieldslib"
archive(syntax, preprocessor) = "pa_fields_conv.cma"
diff --git a/lib/field.ml b/lib/field.ml
index 2c53860..0c7550a 100644
--- a/lib/field.ml
+++ b/lib/field.ml
@@ -1,17 +1,59 @@
-type ('record, 'field) t = {
- name : string;
- setter : ('record -> 'field -> unit) option;
- getter : ('record -> 'field);
- fset : ('record -> 'field -> 'record);
-}
+(* The type [t] should be abstract to make the fset and set functions unavailable
+ for private types at the level of types (and not by putting None in the field).
+ Unfortunately, making the type abstract means that when creating fields (through
+ a [create] function) value restriction kicks in. This is worked around by instead
+ not making the type abstract, but forcing anyone breaking the abstraction to use
+ the [For_generated_code] module, making it obvious to any reader that something ugly
+ is going on.
+ t_with_perm (and derivatives) is the type that users really use. It is a constructor
+ because:
+ 1. it makes type errors more readable (less aliasing)
+ 2. the typer in ocaml 4.01 allows this:
-let name f = f.name
+ module A = struct
+ type t = {a : int}
+ end
+ type t = A.t
+ let f (x : t) = x.a
-let get f r = f.getter r
+ (although with Warning 40: a is used out of scope)
+ which means that if [t_with_perm] was really an alias on [For_generated_code.t],
+ people could say [t.setter] and break the abstraction with no indication that
+ something ugly is going on in the source code.
+ The warning is (I think) for people who want to make their code compatible with
+ previous versions of ocaml, so we may very well turn it off.
-let fset (f : ('r, 'f) t) (r : 'r) (v : 'f) = f.fset r v
+ The type t_with_perm could also have been a [unit -> For_generated_code.t] to work
+ around value restriction and then [For_generated_code.t] would have been a proper
+ abstract type, but it looks like it could impact performance (for example, a fold on a
+ record type with 40 fields would actually allocate the 40 [For_generated_code.t]'s at
+ every single fold.)
+*)
-let setter f = f.setter
+module For_generated_code = struct
+ type ('perm, 'record, 'field) t = {
+ force_variance : 'perm -> unit;
+ (* force [t] to be contravariant in ['perm], because phantom type variables on
+ concrete types don't work that well otherwise (using :> can remove them easily) *)
+ name : string;
+ setter : ('record -> 'field -> unit) option;
+ getter : ('record -> 'field);
+ fset : ('record -> 'field -> 'record);
+ }
+end
-type ('record,'result) user =
- {f : 'field. ('record,'field) t -> 'result}
+type ('perm, 'record, 'field) t_with_perm =
+| Field of ('perm, 'record, 'field) For_generated_code.t
+type ('record, 'field) t = ([ `Read | `Set_and_create], 'record, 'field) t_with_perm
+type ('record, 'field) readonly_t = ([ `Read ], 'record, 'field) t_with_perm
+
+let name (Field f) = f.For_generated_code.name
+
+let get (Field f) r = f.For_generated_code.getter r
+
+let fset (Field f) r v = f.For_generated_code.fset r v
+
+let setter (Field f) = f.For_generated_code.setter
+
+type ('perm, 'record, 'result) user =
+ { f : 'field. ('perm, 'record, 'field) t_with_perm -> 'result }
diff --git a/lib/field.mli b/lib/field.mli
index d8468f9..a88722a 100644
--- a/lib/field.mli
+++ b/lib/field.mli
@@ -1,18 +1,34 @@
(** OCaml record field. *)
+(**/**)
+module For_generated_code : sig
+ (* don't use this by hand, it is only meant for pa_fields_conv *)
+ type ('perm, 'record, 'field) t = {
+ force_variance : 'perm -> unit;
+ name : string;
+ setter : ('record -> 'field -> unit) option;
+ getter : ('record -> 'field);
+ fset : ('record -> 'field -> 'record);
+ }
+end
+(**/**)
+
(* ['record] is the type of the record. ['field] is the type of the
- values stored in the record field with name [name]. *)
-type ('record, 'field) t = {
- name : string;
- setter : ('record -> 'field -> unit) option;
- getter : ('record -> 'field);
- fset : ('record -> 'field -> 'record);
-}
+ values stored in the record field with name [name]. ['perm] is a way
+ of restricting the operations that can be used. *)
+type ('perm, 'record, 'field) t_with_perm =
+| Field of ('perm, 'record, 'field) For_generated_code.t
+
+(* a record field with no restriction *)
+type ('record, 'field) t = ([ `Read | `Set_and_create], 'record, 'field) t_with_perm
+
+(* a record that can only be read, because it belongs to a private type *)
+type ('record, 'field) readonly_t = ([ `Read ], 'record, 'field) t_with_perm
-val name : (_, _) t -> string
-val get : ('r, 'a) t -> 'r -> 'a
-val fset : ('r, 'a) t -> 'r -> 'a -> 'r
-val setter : ('r, 'a) t -> ('r -> 'a -> unit) option
+val name : (_, _, _) t_with_perm -> string
+val get : (_, 'r, 'a) t_with_perm -> 'r -> 'a
+val fset : ([> `Set_and_create], 'r, 'a) t_with_perm -> 'r -> 'a -> 'r
+val setter : ([> `Set_and_create], 'r, 'a) t_with_perm -> ('r -> 'a -> unit) option
-type ('record,'result) user =
- {f : 'field. ('record,'field) t -> 'result}
+type ('perm, 'record, 'result) user =
+ { f : 'field. ('perm, 'record, 'field) t_with_perm -> 'result }
diff --git a/lib_test/fields_test.ml b/lib_test/fields_test.ml
index d63fcff..7c5984b 100644
--- a/lib_test/fields_test.ml
+++ b/lib_test/fields_test.ml
@@ -26,18 +26,22 @@ module Multiple_names = struct
TEST = a { a = 1 } = 1
let _ = Fields_of_a.a
let _ = Fields_of_b.b
+ let _ = (Fields_of_a.a : (_, _) Fieldslib.Field.t :> (_, _) Fieldslib.Field.readonly_t)
end
module Private : sig
type t = private { a : int; mutable b : int }
with fields
- (* exporting the type u wouldn't work for now *)
end = struct
- type t = { a : int; mutable b : int }
+ type u = { a : int; mutable b : int }
+ type t = u = private { a : int; mutable b : int }
with fields
- module U = struct
- type u = t = private { a : int; mutable b : int }
- with fields
- end
+ (* let _ = Fieldslib.Field.setter Fields.a *)
end
+(* let _ = Fieldslib.Field.setter Private.Fields.a *)
let _ = Private.Fields.fold
+let _ = Private.Fields.a
+let _ = Fieldslib.Field.name Private.Fields.a
+let _ = Fieldslib.Field.get Private.Fields.a
+let _ = Private.Fields.map_poly
+ { Fieldslib.Field.f = (fun f -> let _ = Fieldslib.Field.get f in ())}
diff --git a/lib_test/should_fail b/lib_test/should_fail
new file mode 100755
index 0000000..f768ba1
--- /dev/null
+++ b/lib_test/should_fail
@@ -0,0 +1,15 @@
+#!/bin/bash
+
+output="$("$@" 2>&1)"
+code=$?
+if [ $code -eq 0 ]; then
+ echo "The compilation should have failed but did not"
+ if [ "$output" ]; then
+ echo >&2 "$output"
+ fi
+ exit 1
+else
+ if [ "$SHOW" ]; then
+ echo "$output"
+ fi
+fi
diff --git a/lib_test/test1.ml b/lib_test/test1.ml
new file mode 100644
index 0000000..7b0cad5
--- /dev/null
+++ b/lib_test/test1.ml
@@ -0,0 +1,5 @@
+module T = struct
+ type t = { a : int }
+end
+type t = T.t = private { a : int } with fields
+let _ = Fields.map
diff --git a/lib_test/test2.ml b/lib_test/test2.ml
new file mode 100644
index 0000000..6573ce4
--- /dev/null
+++ b/lib_test/test2.ml
@@ -0,0 +1,5 @@
+module T = struct
+ type t = { a : int }
+end
+type t = T.t = private { a : int } with fields
+let _ = Fieldslib.Field.fset Fields.a
diff --git a/lib_test/test3.ml b/lib_test/test3.ml
new file mode 100644
index 0000000..cd8a0ff
--- /dev/null
+++ b/lib_test/test3.ml
@@ -0,0 +1,5 @@
+module T = struct
+ type t = { a : int }
+end
+type t = T.t = private { a : int } with fields
+let _ = Fieldslib.Field.setter Fields.a
diff --git a/lib_test/test4.ml b/lib_test/test4.ml
new file mode 100644
index 0000000..2ae7848
--- /dev/null
+++ b/lib_test/test4.ml
@@ -0,0 +1,5 @@
+module T = struct
+ type t = { a : int }
+end
+type t = T.t = private { a : int } with fields
+let _ = (Fields.a :> (_, _) Fieldslib.Field.t)
diff --git a/lib_test/test5.ml b/lib_test/test5.ml
new file mode 100644
index 0000000..75ecd0f
--- /dev/null
+++ b/lib_test/test5.ml
@@ -0,0 +1,6 @@
+module T : sig
+ type t = private { a : int } with fields
+end = struct
+ type t = { a : int } with fields
+end
+let _ = T.Fields.map
diff --git a/lib_test/test6.ml b/lib_test/test6.ml
new file mode 100644
index 0000000..45b53fa
--- /dev/null
+++ b/lib_test/test6.ml
@@ -0,0 +1,6 @@
+module T : sig
+ type t = private { a : int } with fields
+end = struct
+ type t = { a : int } with fields
+end
+let _ = Fieldslib.Field.fset T.Fields.a
diff --git a/lib_test/test7.ml b/lib_test/test7.ml
new file mode 100644
index 0000000..7b38fe3
--- /dev/null
+++ b/lib_test/test7.ml
@@ -0,0 +1,6 @@
+module T : sig
+ type t = private { a : int } with fields
+end = struct
+ type t = { a : int } with fields
+end
+let _ = Fieldslib.Field.setter T.Fields.a
diff --git a/lib_test/test8.ml b/lib_test/test8.ml
new file mode 100644
index 0000000..cc954a9
--- /dev/null
+++ b/lib_test/test8.ml
@@ -0,0 +1,6 @@
+module T : sig
+ type t = private { a : int } with fields
+end = struct
+ type t = { a : int } with fields
+end
+let _ = (T.Fields.a :> (_, _) Fieldslib.Field.t)
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
index 015f5b5..385938d 100644
--- a/myocamlbuild.ml
+++ b/myocamlbuild.ml
@@ -489,99 +489,4 @@ let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
# 491 "myocamlbuild.ml"
(* OASIS_STOP *)
-
-
-let protectx x ~f ~finally =
- let r = try f x with exn -> finally x; raise exn in
- finally x; r
-
-let rm_rf dir =
- ignore (Printf.ksprintf Sys.command "/bin/rm -rf %S" dir : int)
-
-let temp_dir ?(in_dir = Filename.temp_dir_name) prefix suffix =
- let base = Filename.concat in_dir prefix in
- let rec loop i =
- let dir = base ^ string_of_int i ^ suffix in
- let ret = Printf.ksprintf Sys.command "/bin/mkdir %S 2>/dev/null" dir in
- if ret = 0 then dir
- else if Sys.file_exists dir then loop (i + 1)
- else failwith ("mkdir failed on " ^ dir)
- in loop 0
-
-let read_lines ic =
- let rec loop acc =
- match try Some (input_line ic) with End_of_file -> None with
- | Some line -> loop (line :: acc)
- | None -> List.rev acc
- in loop []
-
-let test cmd =
- match Sys.command cmd with
- | 0 -> true
- | 1 -> false
- | _ -> failwith ("command ^cmd^ failed.")
-
-let sh_lines cmd =
- protectx (Filename.temp_file "ocamlbuild_cmd" ".txt")
- ~f:(fun fn ->
- ignore (Sys.command ("(" ^ cmd ^ ") >" ^ fn) : int);
- protectx (open_in fn) ~f:read_lines ~finally:close_in)
- ~finally:Sys.remove
-
-let getconf var =
- let cmd = Printf.sprintf "getconf %S" var in
- match sh_lines cmd with
- | [] -> None
- | [x] -> Some x
- | _ -> failwith ("`"^cmd^"` returned multiple lines")
-
-let endswith x s =
- let len_x = String.length x and len_s = String.length s in
- (len_x <= len_s) && x = String.sub s (len_s - len_x) len_x
-
-let select_files dir ext =
- List.map (Filename.concat dir)
- (List.filter (endswith ext)
- (Array.to_list (Sys.readdir dir)))
-;;
-
-
-let setup_standard_build_flags () =
- begin match getconf "LFS64_CFLAGS" with
- | None -> ()
- | Some flags -> flag ["compile"; "c"] (S[A"-ccopt"; A flags])
- end;
- let cflags =
- let flags =
- [
- "-pipe";
- "-g";
- "-fPIC";
- "-O2";
- "-fomit-frame-pointer";
- "-fsigned-char";
- "-Wall";
- "-pedantic";
- "-Wextra";
- "-Wunused";
-(* "-Werror"; *)
- "-Wno-long-long";
- ]
- in
- let f flag = [A "-ccopt"; A flag] in
- List.concat (List.map f flags)
- in
- flag ["compile"; "c"] (S cflags);
-
- (* enable warnings; make sure the '@' character isn't in the beginning;
- ms-dos interprets that character specially *)
- flag ["compile"; "ocaml"] (S [A "-w"; A "Aemr-28"; A "-strict-sequence" ])
-;;
-
-let dispatch = function
- | After_rules as e ->
- setup_standard_build_flags ();
- dispatch_default e
- | e -> dispatch_default e
-
-let () = Ocamlbuild_plugin.dispatch dispatch
+Ocamlbuild_plugin.dispatch dispatch_default;;
diff --git a/sample/test.ml b/sample/test.ml
index a0c391f..d5be45f 100644
--- a/sample/test.ml
+++ b/sample/test.ml
@@ -4,7 +4,6 @@ type ('a,'b) t = {
quantity : ('a , 'b) t;
price : int * 'a;
mutable cancelled : bool;
-(* symbol : string; *)
} with fields
type foo = {
@@ -12,12 +11,20 @@ type foo = {
b : int;
} with fields
-module Private = struct
+module Private_in_mli = struct
type ('a,'b) t = {
dir : 'a * 'b;
quantity : ('a , 'b) t;
price : int * 'a;
mutable cancelled : bool;
- (* symbol : string; *)
+ } with fields
+end
+
+module Private_in_ml = struct
+ type ('a,'b) t = ('a,'b) Private_in_mli.t = private {
+ dir : 'a * 'b;
+ quantity : ('a , 'b) t;
+ price : int * 'a;
+ mutable cancelled : bool;
} with fields
end
diff --git a/sample/test.mli b/sample/test.mli
index a0a5d01..0bea76e 100644
--- a/sample/test.mli
+++ b/sample/test.mli
@@ -28,7 +28,7 @@ type foo = {
b : int;
} with fields
-module Private : sig
+module Private_in_mli : sig
type ('a,'b) t = private {
dir : 'a * 'b;
quantity : ('a , 'b) t;
@@ -37,3 +37,15 @@ module Private : sig
(* symbol : string; *)
} with fields
end
+
+module Private_in_ml : sig
+ type ('a,'b) t = ('a,'b) Private_in_mli.t = private {
+ dir : 'a * 'b;
+ quantity : ('a , 'b) t;
+ price : int * 'a;
+ mutable cancelled : bool;
+ (* symbol : string; *)
+ } with fields
+end
+
+
diff --git a/setup.ml b/setup.ml
index af5bf6c..438350f 100644
--- a/setup.ml
+++ b/setup.ml
@@ -1,5 +1,5 @@
(* OASIS_START *)
-(* DO NOT EDIT (digest: 5c81a399294a6d4eab97e02003c9fd66) *)
+(* DO NOT EDIT (digest: 35110c9a8a72ada9ab1448c21e348c48) *)
(*
Regenerated by OASIS v0.3.0
Visit http://oasis.forge.ocamlcore.org for more information and
@@ -5576,7 +5576,7 @@ let setup_t =
ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0");
findlib_version = Some (OASISVersion.VGreaterEqual "1.3.2");
name = "fieldslib";
- version = "109.13.00";
+ version = "109.14.00";
license =
OASISLicense.DEP5License
(OASISLicense.DEP5Unit
@@ -5746,7 +5746,7 @@ let setup_t =
};
oasis_fn = Some "_oasis";
oasis_version = "0.3.0";
- oasis_digest = Some "$\149-\022gO\160+\015\129<T$\198\176\019";
+ oasis_digest = Some "0\152+\1689N\133\170-%+\140\027pf\018";
oasis_exec = None;
oasis_setup_args = [];
setup_update = false;
diff --git a/syntax/pa_fields_conv.ml b/syntax/pa_fields_conv.ml
index 87d3834..e170e2e 100644
--- a/syntax/pa_fields_conv.ml
+++ b/syntax/pa_fields_conv.ml
@@ -67,6 +67,16 @@ let generate_at_least_once rec_ ~f ~combine typedefs =
let raise_unsupported () =
`Error "Unsupported use of fields (you can only use it on records)."
+let perm _loc private_ =
+ match private_ with
+ | true -> <:ctyp< [< `Read ] >>
+ | false -> <:ctyp< [< `Read | `Set_and_create ] >>
+
+let field_t _loc private_ =
+ match private_ with
+ | false -> <:ctyp< Fieldslib.Field.t >>
+ | true -> <:ctyp< Fieldslib.Field.readonly_t >>
+
module Gen_sig = struct
let apply_type _loc ~ty_name ~tps =
List.fold_left tps
@@ -75,15 +85,15 @@ module Gen_sig = struct
let label_arg _loc name ty = Ast.TyLab (_loc, name, ty)
- let field_arg _loc ~record f = fun (name, _m, ty) ->
+ let field_arg _loc ~private_ ~record f = fun (name, _m, ty) ->
label_arg _loc name (
- f ~field: <:ctyp< Fieldslib.Field.t $record$ $ty$ >> ~ty)
+ f ~field: <:ctyp< $field_t _loc private_$ $record$ $ty$ >> ~ty)
;;
let create_fun ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty ->
+ let f = field_arg _loc ~private_:false ~record (fun ~field ~ty ->
let create_f = <:ctyp< 'input__ -> ( $ty$ ) >> in
<:ctyp< $field$ -> 'compile_acc__ -> ($create_f$ * 'compile_acc__) >>
) in
@@ -96,10 +106,10 @@ module Gen_sig = struct
;;
- let fold_fun ~ty_name ~tps _loc ty =
+ let fold_fun ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:_ ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:_ ->
<:ctyp< 'acc__ -> $field$ -> 'acc__ >>) in
let types = List.map fields ~f in
let init_ty = label_arg _loc "init" <:ctyp< 'acc__ >> in
@@ -120,40 +130,40 @@ module Gen_sig = struct
- let bool_fun fun_name ~ty_name ~tps _loc ty =
+ let bool_fun fun_name ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:_ ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:_ ->
<:ctyp< $field$ -> bool >> ) in
let types = List.map fields ~f in
let t = Create.lambda_sig _loc types <:ctyp< bool >> in
<:sig_item< value $lid:fun_name$ : $t$ >>
;;
- let iter_fun ~ty_name ~tps _loc ty =
+ let iter_fun ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:_ ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:_ ->
<:ctyp< $field$ -> unit >>) in
let types = List.map fields ~f in
let t = Create.lambda_sig _loc types <:ctyp< unit >> in
<:sig_item< value iter : $t$ >>
;;
- let direct_iter_fun ~ty_name ~tps _loc ty =
+ let direct_iter_fun ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:field_ty ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:field_ty ->
<:ctyp< $field$ -> $record$ -> $field_ty$ -> unit >>) in
let types = List.map fields ~f in
let t = Create.lambda_sig _loc (record :: types) <:ctyp< unit >> in
<:sig_item< value iter : $t$ >>
;;
- let direct_fold_fun ~ty_name ~tps _loc ty =
+ let direct_fold_fun ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:field_ty ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:field_ty ->
<:ctyp< 'acc__ -> $field$ -> $record$ -> $field_ty$ -> 'acc__ >>) in
let types = List.map fields ~f in
let init_ty = label_arg _loc "init" <:ctyp< 'acc__ >> in
@@ -162,10 +172,10 @@ module Gen_sig = struct
<:sig_item< value fold : $t$ >>
;;
- let to_list_fun ~ty_name ~tps _loc ty =
+ let to_list_fun ~private_ ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty:_ ->
+ let f = field_arg _loc ~private_ ~record (fun ~field ~ty:_ ->
<:ctyp< $field$ -> 'elem__ >>)
in
let types = List.map fields ~f in
@@ -176,7 +186,7 @@ module Gen_sig = struct
let map_fun ~ty_name ~tps _loc ty =
let record = apply_type _loc ~ty_name ~tps in
let fields = Inspect.fields ty in
- let f = field_arg _loc ~record (fun ~field ~ty ->
+ let f = field_arg _loc ~private_:false ~record (fun ~field ~ty ->
<:ctyp< $field$ -> $ty$ >>) in
let types = List.map fields ~f in
let t = Create.lambda_sig _loc (types) record in
@@ -184,7 +194,7 @@ module Gen_sig = struct
;;
- let map_poly ~ty_name ~tps _loc _ =
+ let map_poly ~private_ ~ty_name ~tps _loc _ =
let record = apply_type _loc ~ty_name ~tps in
let tps_names =
List.map
@@ -203,8 +213,9 @@ module Gen_sig = struct
in
<:ctyp<'$lid:loop 0$>>
in
+ let perm = perm _loc private_ in
let t =
- <:ctyp< Fieldslib.Field.user $record$ $fresh_variable$ -> list $fresh_variable$ >>
+ <:ctyp< Fieldslib.Field.user $perm$ $record$ $fresh_variable$ -> list $fresh_variable$ >>
in
<:sig_item< value map_poly : $t$ >>
;;
@@ -217,7 +228,7 @@ module Gen_sig = struct
let conv_field (res_getset, res_fields) (name, m, ty) =
let getter = <:sig_item< value $lid:name$ : $record_ty$ -> $ty$ >> in
let field =
- <:sig_item< value $lid:name$ : Fieldslib.Field.t $record_ty$ $ty$ >>
+ <:sig_item< value $lid:name$ : $field_t _loc private_$ $record_ty$ $ty$ >>
in
match m, private_ with
| `Immutable, _
@@ -238,57 +249,44 @@ module Gen_sig = struct
let create_fun = create_fun ~ty_name ~tps _loc ty in
let simple_create_fun = simple_create_fun ~ty_name ~tps _loc ty in
if ty_name = "t" then
- let iter = iter_fun ~ty_name ~tps _loc ty in
- let fold = fold_fun ~ty_name ~tps _loc ty in
+ let iter = iter_fun ~private_ ~ty_name ~tps _loc ty in
+ let fold = fold_fun ~private_ ~ty_name ~tps _loc ty in
let map = map_fun ~ty_name ~tps _loc ty in
- let map_poly = map_poly ~ty_name ~tps _loc ty in
- let and_f = bool_fun "for_all" ~ty_name ~tps _loc ty in
- let or_f = bool_fun "exists" ~ty_name ~tps _loc ty in
- let to_list = to_list_fun ~ty_name ~tps _loc ty in
- let direct_iter = direct_iter_fun ~ty_name ~tps _loc ty in
- let direct_fold = direct_fold_fun ~ty_name ~tps _loc ty in
+ let map_poly = map_poly ~private_ ~ty_name ~tps _loc ty in
+ let and_f = bool_fun "for_all" ~private_ ~ty_name ~tps _loc ty in
+ let or_f = bool_fun "exists" ~private_ ~ty_name ~tps _loc ty in
+ let to_list = to_list_fun ~private_ ~ty_name ~tps _loc ty in
+ let direct_iter = direct_iter_fun ~private_ ~ty_name ~tps _loc ty in
+ let direct_fold = direct_fold_fun ~private_ ~ty_name ~tps _loc ty in
<:sig_item< $getters_and_setters$ ;
module Fields : sig
value names : list string ;
+ $fields$ ;
+ $fold$ ;
$ if private_
- (* Even though the [set] function in the first-class fields will be None
- if the type is declared private in the implementation, we still can't
- give any access to them here:
-
- First class fields usually contain the [set] function anyway because the
- type is usually private in the interface but not in the
- implementation. And even if they didn't or if the record was non mutable,
- first class fields would still expose the [fset] functions which also
- break the purpose of private types. So first class fields can never be
- exposed and any function using them (ie everything in the else branch
- here) can't be exposed either.
+ (* The ['perm] phantom type prohibits first-class fields from mutating or
+ creating private records, so we can expose them (and fold, etc.).
+
+ However, we still can't expose functions that explicitly create private
+ records.
*)
- then <:sig_item< $fold$; >>
- else <:sig_item<
- $fields$ ;
- $fold$ ;
- $create_fun$ ; $simple_create_fun$ ; $iter$ ; $map$ ; $map_poly$ ;
- $and_f$ ; $or_f$ ; $to_list$ ;
- module Direct : sig
- $direct_iter$ ;
- $direct_fold$ ;
- end ;
- >>
+ then <:sig_item< >>
+ else <:sig_item< $create_fun$ ; $simple_create_fun$ ; $map$ ; >>
$ ;
+ $iter$ ; $and_f$ ; $or_f$ ; $to_list$ ; $map_poly$ ;
+ module Direct : sig
+ $direct_iter$ ;
+ $direct_fold$ ;
+ end ;
end
>>
else
let fields_module = "Fields_of_" ^ ty_name in
<:sig_item<
$getters_and_setters$ ;
- $ if private_
- then <:sig_item< >>
- else <:sig_item<
- module $uid:fields_module$ : sig
- $fields$
- end;
- >>
- $ ;
+ module $uid:fields_module$ : sig
+ $fields$
+ end;
>>
;;
@@ -323,6 +321,9 @@ module Gen_struct = struct
let getter = <:str_item< value $lid:name$ _r__ = _r__.$lid:name$ >> in
let setter, setter_field =
match m, private_ with
+ | `Mutable, true ->
+ <:str_item< >>,
+ <:expr< Some (fun _ _ -> failwith "invalid call to a setter of a private type") >>
| `Mutable, false ->
let setter =
<:str_item<
@@ -331,7 +332,6 @@ module Gen_struct = struct
in
let setter_field = <:expr< Some $lid:"set_" ^ name$ >> in
setter, setter_field
- | `Mutable, true
| `Immutable, _ -> <:str_item< >>, <:expr< None >>
in
let field =
@@ -341,15 +341,22 @@ module Gen_struct = struct
Ast.ExId (_loc, Ast.IdLid (_loc, "v__"))),
rec_id)
in
- let fset = <:expr< fun _r__ v__ -> $e$ >> in
+ let fset =
+ match private_ with
+ | true ->
+ <:expr< fun _ _ -> failwith "Invalid call to an fsetter of a private type" >>
+ | false -> <:expr< fun _r__ v__ -> $e$ >>
+ in
+ let perm = perm _loc private_ in
<:str_item<
- value $lid:name$ =
- ( { Fieldslib.Field.
- name = $str:name$;
- getter = $lid:name$;
- setter = $setter_field$;
- fset = $fset$;
- } : Fieldslib.Field.t _ $field_ty$ )
+ value $lid:name$ : Fieldslib.Field.t_with_perm $perm$ _ $field_ty$ =
+ Fieldslib.Field.Field { Fieldslib.Field.For_generated_code.
+ force_variance = (fun (_ : $perm$) -> ());
+ name = $str:name$;
+ getter = $lid:name$;
+ setter = $setter_field$;
+ fset = $fset$;
+ }
>>
in
( <:str_item< $getter$ ; $setter$ ; $res_getset$ >>,
@@ -578,31 +585,26 @@ module Gen_struct = struct
$getter_and_setters$ ;
module Fields = struct
value names = $names$ ;
+ $fields$;
$ if private_
then <:str_item< >>
- else <:str_item<
- $fields$ ; $create$ ; $simple_create$ ; $iter$ ; $fold$ ; $map$ ;
- $map_poly$ ; $andf$ ; $orf$ ; $to_list$ ;
- module Direct = struct
- $direct_iter$ ;
- $direct_fold$ ;
- end ;
- >>
+ else <:str_item< $create$ ; $simple_create$; $map$; >>
$ ;
+ $iter$ ; $fold$ ; $map_poly$ ;
+ $andf$ ; $orf$ ; $to_list$ ;
+ module Direct = struct
+ $direct_iter$ ;
+ $direct_fold$ ;
+ end ;
end
>>
else
let fields_module = "Fields_of_" ^ record_name in
<:str_item<
$getter_and_setters$ ;
- $ if private_
- then <:str_item< >>
- else <:str_item<
- module $uid:fields_module$ = struct
- $fields$ ;
- end
- >>
- $ ;
+ module $uid:fields_module$ = struct
+ $fields$ ;
+ end
>>
;;
--
fieldslib packaging
More information about the Pkg-ocaml-maint-commits
mailing list