Automatic interface generation and an Stdlib with alerts (#17)

* somewhat automatic interface generation from existing interface files
* an stdlib with alerts
* add syntax check to prevent disabling alerts
* prefab Stdlib drop-ins that can be directly passed to -open flag

src/ast-check/ast_check.ml

@@ -11,6 +11,7 @@ module Messages = struct
     "This identifier contains a name that starts with an Uppercase letter \
      and contains Two__Underscores in a row\n\
      The use of identifiers of this form is not permitted"
+  let alert_control = "This annotation changes which alerts are enabled, which is not permitted"
   let tail_mod_cons =
     "This is a use of the 'Tail Modulo Constructor' \
      program transformation, which is not permitted"
@@ -19,7 +20,7 @@ end
 module Feature = struct
   type t =
     Array | Mutable_member | Object | Loop
-    | Primitive | Internal_name | Tail_mod_cons
+    | Primitive | Internal_name | Alert_control | Tail_mod_cons
 
   let identifiers = [
     Array, "array";
@@ -28,6 +29,7 @@ module Feature = struct
     Loop, "loop";
     Primitive, "primitive";
     Internal_name, "internal_name";
+    Alert_control, "alert_control";
     Tail_mod_cons, "tail_mod_cons";
   ]
 
@@ -41,9 +43,9 @@ module Feature = struct
   let all =
     Set.of_list
       [ Array; Mutable_member; Object; Loop;
-        Primitive; Internal_name; Tail_mod_cons ]
+        Primitive; Internal_name; Alert_control; Tail_mod_cons ]
 
-  let minimum = Set.of_list [ Primitive; Internal_name ]
+  let minimum = Set.of_list [ Primitive; Internal_name; Alert_control ]
   let default = Set.remove Tail_mod_cons all
 
   let to_message : t -> string =
@@ -55,6 +57,7 @@ module Feature = struct
     | Loop -> loop
     | Primitive -> primitive
     | Internal_name -> internal_name
+    | Alert_control -> alert_control
     | Tail_mod_cons -> tail_mod_cons
 end
 
@@ -90,6 +93,7 @@ module Patterns = struct
 
   let exp_loc exp = exp.pexp_loc
   let str_loc str = str.pstr_loc
+  let attr_loc attr = attr.attr_loc
 
   let map1_violations loc feature =
     as__ %> map1 ~f:(fun x -> violation1 (loc x) feature)
@@ -119,6 +123,16 @@ module Patterns = struct
     or (drop1 pstr_class or drop1 pstr_class_type) |> vio Object
     or no_violation ()
 
+  let attr_violations () =
+    let vio feat = map1_violations attr_loc feat in
+    attribute ~name:(string "tail_mod_cons" or string "ocaml.tail_mod_cons")
+      ~payload:(pstr nil)
+      |> vio Tail_mod_cons
+    or attribute ~name:(string "alert" or string "ocaml.alert")
+      ~payload:(single_expr_payload (estring drop))
+      |> vio Alert_control
+    or no_violation ()
+
 end
 
 (** Reject names that look like they could be module names when they contain the
@@ -197,11 +211,7 @@ let iter_violations context =
 
     method! attribute =
       iter ~loc:(fun attr -> attr.attr_loc) super#attribute
-      @@ violation_when
-          (fun attr ->
-            List.mem attr.attr_name.txt
-              ["tail_mod_cons"; "ocaml.tail_mod_cons"])
-          Tail_mod_cons
+      @@ violation_pat Patterns.attr_violations
 
   end
 

src/ast-check/ast_check.mli

@@ -32,7 +32,7 @@ module Feature :
   sig
     type t =
       Array | Mutable_member | Object | Loop
-      | Primitive | Internal_name | Tail_mod_cons
+      | Primitive | Internal_name | Alert_control | Tail_mod_cons
     module Set : Set.S with type elt = t
 
     val to_identifier : t -> string

src/common/util.ml

@@ -18,6 +18,18 @@ let uncons = function [] -> None | x :: xs -> Some (x, xs)
 
 let unsnoc xs = uncons (List.rev xs) |> Option.map (fun (x, xs) -> List.rev xs, x)
 
+(** Same as {!List.equal, but allows lists of different types} *)
+let rec list_equal eq l1 l2 =
+  match l1, l2 with
+  | [], [] -> true
+  | [], _::_ | _::_, [] -> false
+  | a1::l1, a2::l2 -> eq a1 a2 && list_equal eq l1 l2
+
+let[@tail_mod_cons] rec update_assoc f a = function
+  | [] -> (match f None with Some v -> [(a, v)] | None -> [])
+  | (k, v) :: tail when k = a -> (match f (Some v) with Some v' -> (k, v') :: tail | None -> tail)
+  | kv :: tail -> kv :: update_assoc f a tail
+
 let or_option o1 o2 = o1 |> Option.(fold ~some ~none:o2)
 
 let filter_option f = function Some x as o when f x -> o | _ -> None

src/stdlib-variants/dune

@@ -2,7 +2,4 @@
  (name stdlib_variants)
  (public_name less-power.stdlib-variants)
 
- (flags (:standard -nopervasives))
- (libraries common))
-
-(include_subdirs unqualified)
+ (libraries common stdlib_components stdlib_alerts))

src/stdlib-variants/signature-builder/dune

@@ -0,0 +1,93 @@
+(include_subdirs no)
+
+(library
+ (name signature_builder)
+ (public_name less-power.signature-builder)
+ (preprocess
+  (pps ppxlib.metaquot))
+ (modules :standard \ signature_builder_ppx)
+ (libraries ppxlib common))
+
+(library
+ (name signature_builder_ppx)
+ (public_name less-power.signature-builder-ppx)
+ (kind ppx_rewriter)
+ (modules signature_builder_ppx)
+ (libraries ppxlib signature_builder))
+
+(rule
+ (target stdlib_signature_info.ml)
+ (action
+  (with-stdout-to
+   %{target}
+   (run
+    lp-make-interface-description
+    ; to generate this list:
+    ; find "$(ocamlc -where)" -maxdepth 1 -name '*.mli' -execdir bash -c 'echo "%{lib:stdlib:$(basename "$1")}"' -- {} \; | sort
+    %{lib:stdlib:arg.mli}
+    %{lib:stdlib:arrayLabels.mli}
+    %{lib:stdlib:array.mli}
+    %{lib:stdlib:atomic.mli}
+    %{lib:stdlib:bigarray.mli}
+    %{lib:stdlib:bool.mli}
+    %{lib:stdlib:buffer.mli}
+    %{lib:stdlib:bytesLabels.mli}
+    %{lib:stdlib:bytes.mli}
+    %{lib:stdlib:callback.mli}
+    %{lib:stdlib:camlinternalFormatBasics.mli}
+    %{lib:stdlib:camlinternalFormat.mli}
+    %{lib:stdlib:camlinternalLazy.mli}
+    %{lib:stdlib:camlinternalMod.mli}
+    %{lib:stdlib:camlinternalOO.mli}
+    %{lib:stdlib:char.mli}
+    %{lib:stdlib:complex.mli}
+    %{lib:stdlib:condition.mli}
+    %{lib:stdlib:digest.mli}
+    %{lib:stdlib:domain.mli}
+    %{lib:stdlib:effect.mli}
+    %{lib:stdlib:either.mli}
+    %{lib:stdlib:ephemeron.mli}
+    %{lib:stdlib:filename.mli}
+    %{lib:stdlib:float.mli}
+    %{lib:stdlib:format.mli}
+    %{lib:stdlib:fun.mli}
+    %{lib:stdlib:gc.mli}
+    %{lib:stdlib:hashtbl.mli}
+    %{lib:stdlib:in_channel.mli}
+    %{lib:stdlib:int32.mli}
+    %{lib:stdlib:int64.mli}
+    %{lib:stdlib:int.mli}
+    %{lib:stdlib:lazy.mli}
+    %{lib:stdlib:lexing.mli}
+    %{lib:stdlib:listLabels.mli}
+    %{lib:stdlib:list.mli}
+    %{lib:stdlib:map.mli}
+    %{lib:stdlib:marshal.mli}
+    %{lib:stdlib:moreLabels.mli}
+    %{lib:stdlib:mutex.mli}
+    %{lib:stdlib:nativeint.mli}
+    %{lib:stdlib:obj.mli}
+    %{lib:stdlib:oo.mli}
+    %{lib:stdlib:option.mli}
+    %{lib:stdlib:out_channel.mli}
+    %{lib:stdlib:parsing.mli}
+    %{lib:stdlib:printexc.mli}
+    %{lib:stdlib:printf.mli}
+    %{lib:stdlib:queue.mli}
+    %{lib:stdlib:random.mli}
+    %{lib:stdlib:result.mli}
+    %{lib:stdlib:scanf.mli}
+    %{lib:stdlib:semaphore.mli}
+    %{lib:stdlib:seq.mli}
+    %{lib:stdlib:set.mli}
+    %{lib:stdlib:stack.mli}
+    %{lib:stdlib:std_exit.mli}
+    %{lib:stdlib:stdLabels.mli}
+    %{lib:stdlib:stdlib.mli}
+    %{lib:stdlib:stringLabels.mli}
+    %{lib:stdlib:string.mli}
+    %{lib:stdlib:sys.mli}
+    %{lib:stdlib:type.mli}
+    %{lib:stdlib:uchar.mli}
+    %{lib:stdlib:unit.mli}
+    %{lib:stdlib:weak.mli}))))