Stdlib_variants: Avoid types being implicitly duplicated by signature…

… builder (#23)

src/stdlib-variants/signature-builder/signature_builder.ml

@@ -2,7 +2,9 @@ open Ppxlib
 open Common.Util
 
 (** Library and PPX rewriter for building interfaces from existing interfaces
-    by selectively adding and removing interface items. *)
+    by selectively adding and removing interface items.
+
+    See {!Parse} for the full grammar for inclusion specifications. *)
 
 (** {1 Loading saved signatures} *)
 
@@ -87,11 +89,72 @@ type signature_item_pat = { names : longident_loc list; kind : kind option; loc
 
 type include_specs = include_spec list
 and include_spec =
-  | Include_from of { from : longident_loc; items : signature_item_pat Ordered_set.t }
+  | Include_from of { from : longident_loc; items : signature_item_pat Ordered_set.t; loc : Location.t }
   | Include_group of { attributes : attribute list; items : include_specs }
 
 module Parse = struct
 
+  (**
+
+  Parser for include specifications.
+
+  To use the signature builder, first enable the PPX rewriter.
+  With dune, add the PPX rewriter to your component's [dune] file:
+  {@dune[(preprocess (pps less-power.signature-builder-ppx))]}
+  Then, within a signature, use an extension point to include signature items, for example:
+  {[
+  module type Foo : sig
+    [%%include stdlib.stdlib (fst, snd)]
+  end
+  ]}
+
+  Inclusion specifications can be more complex. The full grammar is as follows:
+
+  {@text[
+  include-specs := include-spec | '()' | '(' include-spec {',' include-spec} ')'
+  include-spec :=
+    | from-spec items-spec
+    | '{' 'items =' include-specs ';' ['attributes = __' {attribute} ';'] '}'
+  from-spec := (* qualified path to signature-info to take items from *)
+    lowercase-ident {'.' lowercase-ident}+
+  items-spec := (* ordered set of items *)
+    item-spec | '!standard' | items-spec '-' items-spec | '()' | '(' items-spec {',' items-spec} ')'
+  item-spec := item-names ['@' item-options]
+  item-names := item-name | '[' {item-name ';'}+ ']'
+  item-name := (* refer to values, types, modules, ... *)
+    lowercase-ident | capitalized-ident | '[]'
+  ]}
+
+  The following more complex example includes [t] and [to_string_default]
+  from the standard [Printexc] module, then also includes everything except
+  that type and that value, with each item given the [unsafe] attribute:
+
+  {[
+  [%%include
+    stdlib.printexc (t, to_string_default),
+    { attributes = __ [@alert unsafe "This item is not permitted"];
+      items = stdlib.printexc (!standard - (t, to_string_default)) }
+  ]
+  ]}
+
+  To disambiguate signature items of different kinds with the same name,
+  use the syntax [identifier @ { kind = "kind"}], where [kind] is one of
+  [value], [type], [exception], [module], [module-type]. For example, to
+  include the standard [ref] function:
+
+  {[[%%include stdlib.stdlib (ref @ { kind = "value" })]]}
+
+  The preprocessor will refuse to include types which don't include a type
+  equation (e.g. abstract types and types defined only by constructors). This
+  is because this will create copies of the type, which is generally not the intention.
+  In this case, types must be defined manually without the inclusion mechanism, e.g.:
+
+  {[type ('a, 'b) result = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b]}
+  *)
+
+  (* TODO: make it possible to reference an existing type automatically.
+     Challenge is deciding how to resolve the type to reference. *)
+
   let ordered_set =
     let open Ordered_set in
     let rec impl exp = match exp with
@@ -176,10 +239,10 @@ module Parse = struct
     | exp -> [include_spec ~allow_comma:true exp]
 
   and include_spec ~allow_comma = function
-    | [%expr [%e? from_exp] [%e? items_exp] ] ->
+    | [%expr [%e? from_exp] [%e? items_exp] ] as exp ->
         let from = { txt = dotted_name from_exp; loc = from_exp.pexp_loc } in
         let items = ordered_set items_exp |> Ordered_set.map signature_item_pat in
-        Include_from { from; items }
+        Include_from { from; items; loc = exp.pexp_loc }
     | { pexp_desc = Pexp_record (entries, None); _ } as exp ->
         (* TODO: error on extra and duplicate keys *)
         let entries = List.map (fun (k, v) -> k.txt, v) entries in
@@ -245,21 +308,35 @@ let match_signature_item_pat (pat : signature_item_pat) sigi =
   (match pat.kind with Some k -> match_kind k sigi | None -> true)
   && list_equal (fun p s -> match_lident_name p.txt s) pat.names (signature_item_names sigi)
 
-let eval_pat_ordered_set signature s =
+let eval_pat_ordered_set loc signature s =
   let indexed =
     signature |> List.filter is_signature_item_selectable
-    |> List.mapi (fun i x -> i, x)
+    |> List.mapi (fun i x -> i, (x, loc))
   in
   let lookup pat =
-    match List.filter (snd %> match_signature_item_pat pat) indexed with
-    | [item] -> item
+    match List.filter (snd %> fst %> match_signature_item_pat pat) indexed with
+    | [i, (item, _)] -> i, (item, pat.loc)
     | [] -> Location.raise_errorf ~loc:pat.loc "Did not match any signature items"
     | items -> Location.raise_errorf ~loc:pat.loc
         "Ambiguous: matched %d signature items. Hint: use { kind = \"...\" } to disambiguate." (List.length items)
   in
+  let check_psigi item loc =
+    match item.psig_desc with
+    | Psig_type (_, tdcls) ->
+        tdcls |> List.iter (function
+          | { ptype_manifest = None; ptype_name; _ } ->
+              Location.raise_errorf ~loc
+                ("Included type '%s' has no manifest. You should include it " ^^
+                "manually and (optionally) specify a type equality, " ^^
+                "e.g. type t = Foo.t")
+                ptype_name.txt
+          | _ -> ())
+    | _ -> ()
+  in
   Ordered_set.map lookup s
   |> Ordered_set.eval ~eq:(fun (i1, _) (i2, _) -> i1 = i2) indexed
   |> List.map snd
+  |> List.map (fun (item, loc) -> check_psigi item loc; item)
 
 let modify_attributes f sigi =
   let desc = match sigi.psig_desc with
@@ -288,14 +365,14 @@ let rec eval_include_specs sig_infos specs =
   List.concat_map (eval_include_spec sig_infos) specs
 
 and eval_include_spec sig_infos = function
-  | Include_from { from; items } ->
+  | Include_from { from; items; loc } ->
       let[@warning "-8"] p :: ps = Longident.flatten_exn from.txt in
       let signature =
         match infos_get_signature p ps sig_infos with
         | Some s -> s
         | None -> Location.raise_errorf ~loc:from.loc "Unknown signature"
       in
-      eval_pat_ordered_set signature items
+      eval_pat_ordered_set loc signature items
   | Include_group { attributes; items = spec_items } ->
       eval_include_specs sig_infos spec_items
       |> List.map (modify_attributes (fun attr -> attr @ attributes))
@@ -311,5 +388,13 @@ let default_sig_infos = [
 let ppx_include ?(sig_infos = default_sig_infos) ~ctxt exp =
   let loc = Expansion_context.Extension.extension_point_loc ctxt in
   let module B = Ast_builder.Make (struct let loc = loc end) in
-  let sig_items = Parse.include_specs exp |> eval_include_specs sig_infos in
-  B.psig_include (B.include_infos (B.pmty_signature sig_items))
+  try
+    let sig_items = Parse.include_specs exp |> eval_include_specs sig_infos in
+    B.psig_include (B.include_infos (B.pmty_signature sig_items))
+  with e ->
+    (* Note: the docs recommend embedding extension errors as deeply as
+       possible. But that makes the code significantly more complex (everything
+       has to be in Result.t), for no real gain (dev experience is fine as-is) *)
+    match Location.Error.of_exn e with
+    | Some loc_err -> B.psig_extension (Location.Error.to_extension loc_err) []
+    | None -> raise e

src/stdlib-variants/stdlib-alerts/stdlib_alerts.ml

@@ -57,10 +57,18 @@ module type Float_alerting = sig
 end
 
 module type Hashtbl_alerting = sig
+  type[@alert impure "Hash tables are not permitted"] ('a, 'b) t = ('a, 'b) Hashtbl.t
+  type[@alert impure "Hash tables are not permitted"] statistics = Hashtbl.statistics = {
+    num_bindings: int;
+    num_buckets: int;
+    max_bucket_length: int;
+    bucket_histogram: int array;
+  }
+
   [%%include
     stdlib.hashtbl (hash, seeded_hash, hash_param, seeded_hash_param),
     { attributes = __ [@alert impure "Hash tables are not permitted"];
-      items = stdlib.hashtbl (!standard - (hash, seeded_hash, hash_param, seeded_hash_param)) }
+      items = stdlib.hashtbl (!standard - (t, statistics, hash, seeded_hash, hash_param, seeded_hash_param)) }
   ]
 end
 
@@ -89,11 +97,24 @@ module type MoreLabels_alerting = sig
 end
 
 module type Printexc_alerting = sig
+  type[@alert unsafe "This item is not permitted"] raw_backtrace = Printexc.raw_backtrace
+  type[@alert unsafe "This item is not permitted"] raw_backtrace_slot = Printexc.raw_backtrace_slot
+  type[@alert unsafe "This item is not permitted"] backtrace_slot = Printexc.backtrace_slot
+  type[@alert unsafe "This item is not permitted"] location = Printexc.location = {
+    filename : string;
+    line_number : int;
+    start_char : int;
+    end_char : int;
+  }
+
   (* only to_string_default can be expected to be pure, not to_string *)
   [%%include
     stdlib.printexc (t, to_string_default),
     { attributes = __ [@alert unsafe "This item is not permitted"];
-      items = stdlib.printexc (!standard - (t, to_string_default)) }
+      items = stdlib.printexc (
+        !standard
+        - (t, raw_backtrace, raw_backtrace_slot, backtrace_slot, location, to_string_default)
+      ) }
   ]
 end
 
@@ -120,8 +141,11 @@ module type Scanf_alerting = sig
 end
 
 module type Seq_alerting = sig
+  type 'a t = unit -> 'a node
+  and 'a node = 'a Seq.node = Nil | Cons of 'a * 'a t
+
   [%%include
-    stdlib.seq (!standard - (once, Forced_twice, to_dispenser)),
+    stdlib.seq (!standard - ([t; node], once, Forced_twice, to_dispenser)),
     { attributes = __ [@alert impure "This imperative programming item is not permitted"];
       items = stdlib.seq (once, Forced_twice, to_dispenser) }
   ]
@@ -156,7 +180,10 @@ module type String_alerting = sig
 end
 
 module type Uchar_alerting = sig
-  [%%include stdlib.uchar (!standard - (unsafe_of_int, unsafe_to_char))]
+  type t = Uchar.t [@@immediate]
+  type utf_decode = Uchar.utf_decode [@@immediate]
+
+  [%%include stdlib.uchar (!standard - (t, utf_decode @ {kind = "type"}, unsafe_of_int, unsafe_to_char))]
 end
 
 
@@ -233,9 +260,16 @@ module type Stdlib_alerting = sig
     log, log10, log1p, sin, sinh, asinh, sqrt, tan, tanh, atanh,
     ceil, floor, abs_float, copysign, mod_float, frexp, ldexp, modf,
     float, float_of_int, truncate, int_of_float, infinity, neg_infinity, nan,
-    max_float, min_float, epsilon_float, fpclass, classify_float
+    max_float, min_float, epsilon_float, classify_float
   )]
 
+  type fpclass = Stdlib.fpclass =
+    | FP_normal
+    | FP_subnormal
+    | FP_zero
+    | FP_infinite
+    | FP_nan
+
   (** {1 String operations}
       More in {!Stdlib.String} *)
 
@@ -273,10 +307,23 @@ module type Stdlib_alerting = sig
   (** {1 I/O operations}
       This is regular, unmocked, IO. *)
 
+  type[@alert input_output "Input/output is not permitted"] in_channel = Stdlib.in_channel
+  type[@alert input_output "Input/output is not permitted"] out_channel = Stdlib.out_channel
+  type[@alert input_output "Input/output is not permitted"] open_flag = Stdlib.open_flag =
+    | Open_rdonly
+    | Open_wronly
+    | Open_append
+    | Open_creat
+    | Open_trunc
+    | Open_excl
+    | Open_binary
+    | Open_text
+    | Open_nonblock
+
   [%%include {
     attributes = __ [@alert input_output "Input/output is not permitted"];
     items = stdlib.stdlib (
-      in_channel, out_channel, stdin, stdout, stderr,
+      stdin, stdout, stderr,
       (* Output functions on standard output *)
       print_char, print_string, print_bytes, print_int, print_float,
       print_endline, print_newline,
@@ -286,7 +333,7 @@ module type Stdlib_alerting = sig
       (* Input functions on standard input *)
       read_line, read_int_opt, read_int, read_float_opt, read_float,
       (* General output functions *)
-      open_flag, open_out, open_out_bin, open_out_gen, flush, flush_all,
+      open_out, open_out_bin, open_out_gen, flush, flush_all,
       output_char, output_string, output_bytes, output, output_substring,
       output_byte, output_binary_int, output_value, seek_out, pos_out,
       out_channel_length, close_out, close_out_noerr, set_binary_mode_out,
@@ -302,18 +349,24 @@ module type Stdlib_alerting = sig
 
   (** {1 References} *)
 
+  type 'a ref = 'a Stdlib.ref
+
   [%%include {
     attributes = __ [@alert impure "References are not permitted"];
     items = stdlib.stdlib (
-      ref @ { kind = "type" }, ref @ { kind = "value" },
+      ref @ { kind = "value" },
       ( ! ), ( := ), incr, decr
     )
   }]
 
   (** {1 Result type}
       More in {!Stdlib.Result} *)
 
-  [%%include stdlib.stdlib result ]
+  (* If we just included result into the signature, it would define a new type,
+     which we would have to reference everywhere else. For example, we would
+     not be able to write [module Result = Result], since that would reference
+     the original definition.*)
+  type ('a, 'b) result = ('a, 'b) Stdlib.result = Ok of 'a | Error of 'b
 
   (** {1 Format strings}
       More in {!Stdlib.Scanf}, {!Stdlib.Printf}, and {!Stdlib.Format} *)

src/stdlib-variants/stdlib-alerts/threads_alerts.ml

@@ -3,9 +3,11 @@
 
 module type Thread_alerting = sig
 
+  type t = Thread.t
+
   [%%include
     (* [exit] is deprecated, but not harmful *)
-    threads.thread (t, create, self, id, Exit, exit, delay, join, yield, default_uncaught_exception_handler),
+    threads.thread (create, self, id, Exit, exit, delay, join, yield, default_uncaught_exception_handler),
     { attributes = __ [@alert unsafe "This function is not permitted"];
       items = threads.thread (wait_timed_read, wait_timed_write, select, wait_pid, sigmask, wait_signal) },
     { attributes = __ [@alert impure "This imperative programming function is not permitted"];
@@ -14,7 +16,11 @@ module type Thread_alerting = sig
 
 end
 
-module type Event_alerting = sig [%%include threads.event !standard] end
+module type Event_alerting = sig
+  type 'a channel = 'a Event.channel
+  type 'a event = 'a Event.event
+  [%%include threads.event (!standard - (channel, event))]
+end
 
 
 module Thread_alerting : Thread_alerting = Thread