diff --git a/Makefile b/Makefile index fb8e9cc..2064bec 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,10 @@ OCAMLC ?= ocamlc .PHONY: all test clean -all: fieldglass.cma +all: fieldglass.cma rewrite + +rewrite: rewrite.ml + $(OCAMLC) -I +compiler-libs ocamlcommon.cma $< -o $@ fieldglass.cmi: fieldglass.mli $(OCAMLC) -c $< @@ -15,6 +18,8 @@ fieldglass.cma: fieldglass.cmo test: all $(OCAMLC) fieldglass.cma runtime.ml -o runtime.byte ./runtime.byte + $(OCAMLC) -ppx ./rewrite fieldglass.cma record.ml -o record.byte + ./record.byte clean: rm -f *.cmi *.cmo *.cma *.byte rewrite diff --git a/README.md b/README.md index 40c2f64..939cb31 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,9 @@ Lenses for reading and updating immutable data in OCaml. +Annotate a record with `[@@fieldglass generate]` to generate field accessors. +The `[@@lens generate]` spelling is also accepted. + Build with `make`; run the checks with `make test`. The `_hd` and `_tl` lenses raise `Invalid_argument` on empty lists. diff --git a/fieldglass.install b/fieldglass.install index 6fc7c99..6698d8f 100644 --- a/fieldglass.install +++ b/fieldglass.install @@ -1 +1,2 @@ +bin: ["rewrite" {"fieldglass"}] lib: ["fieldglass.cmi" "fieldglass.cma" "fieldglass.mli" "META"] diff --git a/record.ml b/record.ml new file mode 100644 index 0000000..7e5da30 --- /dev/null +++ b/record.ml @@ -0,0 +1,13 @@ +module Colour = struct + type t = { red : int; green : int; blue : int } [@@fieldglass generate] +end + +module Legacy = struct + type t = { value : string } [@@lens generate] +end + +let () = + let colour = Colour.{ red = 3; green = 4; blue = 5 } in + assert (Colour.red colour = 3); + assert (Colour.green colour = 4); + assert (Legacy.value Legacy.{ value = "grey" } = "grey") diff --git a/rewrite.ml b/rewrite.ml new file mode 100644 index 0000000..23cc164 --- /dev/null +++ b/rewrite.ml @@ -0,0 +1,50 @@ +open Asttypes +open Parsetree +open Ast_helper + +let ident ~loc name = Location.mkloc (Longident.Lident name) loc +let value ~loc name = Exp.ident ~loc (ident ~loc name) +let variable ~loc name = Pat.var ~loc (Location.mkloc name loc) +let lambda ~loc label pattern body = Exp.fun_ ~loc label None pattern body + +let is_marker (name, _) = name.txt = "fieldglass" || name.txt = "lens" + +let configured declaration = + match List.filter is_marker declaration.ptype_attributes with + | [] -> false + | [(_, PStr [{ pstr_desc = Pstr_eval + ({ pexp_desc = Pexp_ident { txt = Longident.Lident "generate"; _ }; _ }, _); _ }])] -> true + | _ -> Location.raise_errorf ~loc:declaration.ptype_loc + "fieldglass: expected [@@fieldglass generate]" + +let generate declaration = + let loc = declaration.ptype_loc in + let fields = match declaration.ptype_kind with + | Ptype_record fields -> fields + | _ -> Location.raise_errorf ~loc "fieldglass: expected a record type" + in + let source = value ~loc "__fg_source" in + let source_pattern = Pat.constraint_ ~loc (variable ~loc "__fg_source") + (Typ.constr ~loc (ident ~loc declaration.ptype_name.txt) + (List.map (fun _ -> Typ.any ~loc ()) declaration.ptype_params)) in + List.map (fun field -> + let name = field.pld_name.txt in + let getter = lambda ~loc Nolabel source_pattern + (Exp.field ~loc source (ident ~loc name)) in + Str.value ~loc Nonrecursive [Vb.mk ~loc (variable ~loc name) getter]) fields + +let structure mapper items = + List.concat (List.map (fun item -> + let item = Ast_mapper.default_mapper.structure_item mapper item in + match item.pstr_desc with + | Pstr_type (recursive, declarations) -> + let generated = List.concat (List.map (fun declaration -> + if configured declaration then generate declaration else []) declarations) in + 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 () = Ast_mapper.register "fieldglass" + (fun _ -> { Ast_mapper.default_mapper with structure })