The following commit has been merged in the upstream branch: commit 4dbb6b79d18cf8a5d0f4be2be1fd48d202fae941 Author: Stephane Glondu <st...@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 <opensou...@janestreet.com> Copyrights: (C) 2009-2013 Jane Street Capital LLC <opensou...@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 _______________________________________________ Pkg-ocaml-maint-commits mailing list Pkg-ocaml-maint-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits