From faefa72427685dfd82fcb034283e3ac7a313256f Mon Sep 17 00:00:00 2001
From: sneeker <s@cpl0.zip>
Date: Sun, 7 Apr 2019 10:12:51 +0000
Subject: [PATCH] Select generated operations without introducing hidden
 dependencies

---
 Makefile   |  1 +
 error.sh   | 27 +++++++++++++++++++++++++++
 record.ml  | 17 +++++++++++++++++
 rewrite.ml | 26 +++++++++++++++++++-------
 4 files changed, 64 insertions(+), 7 deletions(-)
 create mode 100644 error.sh

diff --git a/Makefile b/Makefile
index 2064bec..80100b1 100644
--- a/Makefile
+++ b/Makefile
@@ -20,6 +20,7 @@ test: all
 	./runtime.byte
 	$(OCAMLC) -ppx ./rewrite fieldglass.cma record.ml -o record.byte
 	./record.byte
+	OCAMLC=$(OCAMLC) sh error.sh
 
 clean:
 	rm -f *.cmi *.cmo *.cma *.byte rewrite
diff --git a/error.sh b/error.sh
new file mode 100644
index 0000000..8cec381
--- /dev/null
+++ b/error.sh
@@ -0,0 +1,27 @@
+#!/bin/sh
+set -eu
+directory=$(mktemp -d)
+trap 'rm -rf "$directory"' EXIT HUP INT TERM
+
+reject() {
+  printf '%s\n' "$1" > "$directory/rejected.ml"
+  if "${OCAMLC:-ocamlc}" -ppx ./rewrite -c "$directory/rejected.ml" 2> "$directory/error"; then
+    echo "Unexpected compilation success: $1" >&2
+    exit 1
+  fi
+  if ! grep -q "$2" "$directory/error"; then
+    cat "$directory/error" >&2
+    exit 1
+  fi
+}
+
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get]
+let _ = colour' 'Unbound value colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_set]
+let _ = set_colour' 'Unbound value set_colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_update]
+let _ = update_colour' 'Unbound value update_colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_lens]
+let _ = _colour' 'Unbound value _colour'
+reject 'type t = { colour : string } [@@fieldglass generate ~just_lens]
+let _ = colour' 'Unbound value colour'
diff --git a/record.ml b/record.ml
index c35e2cb..b8e5366 100644
--- a/record.ml
+++ b/record.ml
@@ -116,3 +116,20 @@ let () =
   assert (Fieldglass.set Ordered._count 2 Ordered.{ count = 1 } = Ordered.{ count = 2 });
   assert (Positional.update_count Positional.{ count = 1 } succ = Positional.{ count = 2 });
   assert (Last.update_count succ Last.{ count = 1 } = Last.{ count = 2 })
+
+module Pairs = struct
+  type t = { colour : string } [@@fieldglass generate ~just_lens]
+end
+
+module Silent = struct
+  type t = { colour : string } [@@fieldglass generate ~just_lens ~no_lens]
+end
+
+module Functions = struct
+  type t = { colour : string } [@@fieldglass generate ~no_lens ~no_get:false]
+end
+
+let () =
+  assert (Fieldglass.view Pairs._colour Pairs.{ colour = "grey" } = "grey");
+  assert (Silent.{ colour = "grey" }.colour = "grey");
+  assert (Functions.colour Functions.{ colour = "grey" } = "grey")
diff --git a/rewrite.ml b/rewrite.ml
index 9216062..d1fa119 100644
--- a/rewrite.ml
+++ b/rewrite.ml
@@ -17,10 +17,15 @@ type options = {
   update_prefix : string;
   self_first : bool;
   function_label : string option;
+  getters : bool;
+  setters : bool;
+  updaters : bool;
+  lenses : bool;
 }
 let defaults = { field_prefix = Plain; get_prefix = None;
                  set_prefix = "set"; update_prefix = "update";
-                 self_first = false; function_label = Some "f" }
+                 self_first = false; function_label = Some "f";
+                 getters = true; setters = true; updaters = true; lenses = true }
 
 let word expression =
   match expression.pexp_desc with
@@ -49,6 +54,13 @@ let configure options (label, expression) =
   | Labelled "func_named_arg" -> { options with function_label = Some (word expression) }
   | Labelled "func_no_named_arg" ->
       { options with function_label = if flag "func_no_named_arg" expression then None else Some "f" }
+  | Labelled "no_get" -> { options with getters = not (flag "no_get" expression) }
+  | Labelled "no_set" -> { options with setters = not (flag "no_set" expression) }
+  | Labelled "no_update" -> { options with updaters = not (flag "no_update" expression) }
+  | Labelled "no_lens" -> { options with lenses = not (flag "no_lens" expression) }
+  | Labelled "just_lens" ->
+      let functions = not (flag "just_lens" expression) in
+      { options with getters = functions; setters = functions; updaters = functions }
   | _ -> Location.raise_errorf ~loc:expression.pexp_loc
       "fieldglass: unrecognised configuration option"
 
@@ -110,12 +122,12 @@ let generate options declaration =
     let updater = arguments options.self_first label "__fg_function"
            (replace (Exp.apply ~loc (value ~loc "__fg_function")
               [Nolabel, Exp.field ~loc source (ident ~loc name)])) in
-    List.map (fun (name, body) ->
-      Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body])
-      [(match options.get_prefix with None -> short_name | Some prefix -> prefix ^ "_" ^ short_name), getter;
-       options.set_prefix ^ "_" ^ short_name, setter options.self_first;
-       options.update_prefix ^ "_" ^ short_name, updater;
-       "_" ^ short_name, Exp.tuple ~loc [getter; setter false]]) fields (field_names fields))
+    List.concat (List.map (fun (enabled, name, body) ->
+      if enabled then [Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body]] else [])
+      [options.getters, (match options.get_prefix with None -> short_name | Some prefix -> prefix ^ "_" ^ short_name), getter;
+       options.setters, options.set_prefix ^ "_" ^ short_name, setter options.self_first;
+       options.updaters, options.update_prefix ^ "_" ^ short_name, updater;
+       options.lenses, "_" ^ short_name, Exp.tuple ~loc [getter; setter false]])) fields (field_names fields))
 
 let structure mapper items =
   List.concat (List.map (fun item ->