diff --git a/error.sh b/error.sh index 8cec381..24deed6 100644 --- a/error.sh +++ b/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] diff --git a/rewrite.ml b/rewrite.ml index 56b4a50..335766d 100644 --- a/rewrite.ml +++ b/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 })