Validate configuration and diagnose unsupported record declarations

error.sh

@@ -17,6 +17,21 @@ reject() {
 
 reject 'type t = { colour : string } [@@fieldglass generate ~no_get]
 let _ = colour' 'Unbound value colour'
+reject 'type t = A [@@fieldglass generate]' 'fieldglass: expected a record'
+reject 'type t = { colour : string } [@@fieldglass invalid]' 'fieldglass: expected generate'
+reject 'type t = { colour : string } [@@fieldglass generate ~unknown]' 'fieldglass: unrecognised'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get:3]' 'fieldglass: expected a boolean'
+reject 'type t = { colour : string } [@@fieldglass generate ~field_prefix:3]' 'fieldglass: expected an identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~field_prefix:"a b"]' 'fieldglass: invalid generated identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~func_named_arg:"type"]' 'fieldglass: invalid generated identifier'
+reject 'type t = { colour : string } [@@fieldglass generate ~no_get ~no_get]' 'fieldglass: duplicate option'
+reject 'type t = { colour : string } [@@fieldglass generate 3]' 'fieldglass: expected a labelled option'
+reject 'type t = { colour : string } [@@fieldglass generate] [@@lens generate]' 'fieldglass: expected'
+reject 'type t = { x : int; set_x : int } [@@fieldglass generate]' 'fieldglass: duplicate generated binding'
+reject 'type a = { value : int } and b = { value : string } [@@fieldglass generate]' 'fieldglass: duplicate generated binding'
+reject 'type t = private { colour : string } [@@fieldglass generate]' 'fieldglass: private records'
+reject "type t = { apply : 'a. 'a -> 'a } [@@fieldglass generate]" 'fieldglass: polymorphic fields'
+reject 'module type S = sig type t = { colour : string } [@@fieldglass generate] end' 'fieldglass: generate accessors in an implementation'
 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]

rewrite.ml

@@ -9,6 +9,16 @@ let lambda ~loc label pattern body = Exp.fun_ ~loc label None pattern body
 
 let is_marker (name, _) = name.txt = "fieldglass" || name.txt = "lens"
 
+let check_identifier ~loc name =
+  let input = Lexing.from_string name in
+  let valid = try
+      match Lexer.token input with
+      | Parser.LIDENT parsed when parsed = name -> Lexer.token input = Parser.EOF
+      | _ -> false
+    with Lexer.Error _ -> false in
+  if not valid then Location.raise_errorf ~loc
+      "fieldglass: invalid generated identifier %S" name
+
 type prefix = Plain | Named of string | Type_name
 type options = {
   field_prefix : prefix;
@@ -51,7 +61,10 @@ let configure options (label, expression) =
   | Labelled "set_prefix" -> { options with set_prefix = word expression }
   | Labelled "update_prefix" -> { options with update_prefix = word expression }
   | Labelled "self_arg_first" -> { options with self_first = flag "self_arg_first" expression }
-  | Labelled "func_named_arg" -> { options with function_label = Some (word expression) }
+  | Labelled "func_named_arg" ->
+      let name = word expression in
+      check_identifier ~loc:expression.pexp_loc name;
+      { options with function_label = Some name }
   | 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) }
@@ -73,6 +86,15 @@ let configured declaration =
         | Pexp_apply ({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, arguments) -> arguments
         | _ -> Location.raise_errorf ~loc:expression.pexp_loc
             "fieldglass: expected generate followed by labelled options" in
+      let seen = Hashtbl.create 8 in
+      List.iter (fun (label, argument) ->
+        match label with
+        | Labelled name ->
+            if Hashtbl.mem seen name then Location.raise_errorf ~loc:argument.pexp_loc
+                "fieldglass: duplicate option %s" name;
+            Hashtbl.add seen name ()
+        | _ -> Location.raise_errorf ~loc:argument.pexp_loc
+            "fieldglass: expected a labelled option") arguments;
       Some arguments
   | _ -> Location.raise_errorf ~loc:declaration.ptype_loc
       "fieldglass: expected [@@fieldglass generate]"
@@ -98,6 +120,13 @@ let generate options declaration =
     | Ptype_record fields -> fields
     | _ -> Location.raise_errorf ~loc "fieldglass: expected a record type"
   in
+  let writes = options.setters || options.updaters || options.lenses in
+  if declaration.ptype_private = Private && writes then
+    Location.raise_errorf ~loc "fieldglass: private records only support getters";
+  List.iter (fun field -> match field.pld_type.ptyp_desc with
+    | Ptyp_poly (_ :: _, _) when writes -> Location.raise_errorf ~loc:field.pld_loc
+        "fieldglass: polymorphic fields only support getters"
+    | _ -> ()) fields;
   let source = value ~loc "__fg_source" in
   let record_type () = Typ.constr ~loc (ident ~loc declaration.ptype_name.txt)
       (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params) in
@@ -125,7 +154,10 @@ let generate options declaration =
            (replace (Exp.apply ~loc (value ~loc "__fg_function")
               [Nolabel, Exp.field ~loc source (ident ~loc name)])) in
     List.concat (List.map (fun (enabled, name, body) ->
-      if enabled then [Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body]] else [])
+      if enabled then begin
+        check_identifier ~loc name;
+        [Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) body]]
+      end 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;
@@ -143,11 +175,28 @@ let structure mapper items =
             let options = List.fold_left configure defaults arguments in
             List.concat (List.map (generate options) declarations)
           else [] in
+        let names = Hashtbl.create 16 in
+        List.iter (fun item -> match item.pstr_desc with
+          | Pstr_value (_, [{ pvb_pat = { ppat_desc = Ppat_var name; _ }; _ }]) ->
+              if Hashtbl.mem names name.txt then Location.raise_errorf ~loc:name.loc
+                  "fieldglass: duplicate generated binding %s; customise the prefixes" name.txt;
+              Hashtbl.add names name.txt ()
+          | _ -> ()) generated;
         let declarations = List.map (fun declaration ->
           { declaration with ptype_attributes =
               List.filter (fun attribute -> not (is_marker attribute)) declaration.ptype_attributes }) declarations in
         { item with pstr_desc = Pstr_type (recursive, declarations) } :: generated
     | _ -> [item]) items)
 
+let signature_item mapper item =
+  (match item.psig_desc with
+   | Psig_type (_, declarations) ->
+       List.iter (fun declaration ->
+         if List.exists is_marker declaration.ptype_attributes then
+           Location.raise_errorf ~loc:declaration.ptype_loc
+             "fieldglass: generate accessors in an implementation, not a signature") declarations
+   | _ -> ());
+  Ast_mapper.default_mapper.signature_item mapper item
+
 let () = Ast_mapper.register "fieldglass"
-    (fun _ -> { Ast_mapper.default_mapper with structure })
+    (fun _ -> { Ast_mapper.default_mapper with structure; signature_item })