Commits

Markus Mottl committed 5c607ca

Implemented default record fields with type_conv and sexplib

  • Participants
  • Parent commits bb49e0c

Comments (0)

Files changed (3)

File base/sexplib/syntax/pa_sexp_conv.ml

 
 open Syntax
 
-module type Record_defaults = sig
-  val add : Loc.t -> ?do_not_emit:bool -> Ast.expr -> unit
-  val lookup : Loc.t -> (Ast.expr * [ `Emit | `Do_not_emit ]) option
-end
-
-module Record_defaults : Record_defaults = struct
-  let store = Hashtbl.create 0
-
-  let add key ?(do_not_emit = false) expr =
-    let emit = if do_not_emit then `Do_not_emit else `Emit in
-    Hashtbl.add store ~key ~data:(expr, emit)
-
-  let lookup key = try Some (Hashtbl.find store key) with Not_found -> None
-end
-
 module Gen = Pa_type_conv.Gen
 
 (* Utility functions *)
 
 (* Generator for converters of OCaml-values to S-expressions *)
 module Generate_sexp_of = struct
+  (* Handling of record defaults *)
+
+  type record_field_handler = [ `keep | `drop | `drop_if of Ast.expr ]
+
+  let record_field_handlers = Hashtbl.create 0
+
+  let get_record_field_handler loc =
+    try Hashtbl.find record_field_handlers loc
+    with Not_found -> `keep
+
+  let check_record_field_handler loc =
+    if Hashtbl.mem record_field_handlers loc then
+      Loc.raise loc (Failure "sexp record field handler defined twice")
+
+  let () =
+    Pa_type_conv.add_record_generator "sexp_drop_default" (fun loc ->
+      check_record_field_handler loc;
+      Hashtbl.replace record_field_handlers loc `drop)
+
+  let () =
+    Pa_type_conv.add_record_generator_with_arg "sexp_drop_if"
+      Syntax.expr (fun expr_opt loc ->
+        check_record_field_handler loc;
+        let test =
+          match expr_opt with
+          | Some expr -> expr
+          | None -> Loc.raise loc (Failure "could not parse expression")
+        in
+        Hashtbl.replace record_field_handlers loc (`drop_if test))
+
+  (* Make abstract calls *)
   let mk_abst_call loc tn rev_path =
     <:expr@loc<
       $id:Gen.ident_of_rev_path loc (("sexp_of_" ^ tn) :: rev_path)$
     let p = <:patt@loc< $lid:name$ = $lid:"v_" ^ name$ >> in
     <:patt@loc< $patt$; $p$ >>
 
-  let sexp_of_default_field patt expr name tp ?sexp_of empty =
+  let sexp_of_record_field patt expr name tp ?sexp_of test =
     let loc = Ast.loc_of_ctyp tp in
     let patt = mk_rec_patt loc patt name in
     let cnv_expr =
       let v_name = <:expr@loc< $lid: "v_" ^ name$ >> in
       <:expr@loc<
         let bnds =
-          if $v_name$ = $empty$ then bnds
+          if $test$ $v_name$ then bnds
           else
             let arg = $cnv_expr$ $v_name$ in
             let bnd =
     in
     patt, expr
 
+  let sexp_of_default_field patt expr name tp ?sexp_of default =
+    let loc = Ast.loc_of_expr default in
+    sexp_of_record_field patt expr name tp ?sexp_of
+      <:expr@loc< (=) $default$ >>
+
   let sexp_of_record flds_ctyp =
     let flds = Ast.list_of_ctyp flds_ctyp [] in
     let rec coll (patt, expr) = function
             ~sexp_of:<:expr@loc< sexp_of_array >> <:expr@loc< [||] >>
       | <:ctyp@loc< $lid:name$ : mutable $tp$ >>
       | <:ctyp@loc< $lid:name$ : $tp$ >> ->
-          begin match Record_defaults.lookup loc with
-          | Some (default, `Do_not_emit) ->
-              sexp_of_default_field patt expr name tp default
-          | _ ->
-              let patt = mk_rec_patt loc patt name in
-              let vname = <:expr@loc< $lid:"v_" ^ name$ >> in
-              let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in
-              let expr =
-                <:expr@loc<
-                  let arg = $cnv_expr$ in
-                  let bnd =
-                    Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg]
-                  in
-                  let bnds = [ bnd :: bnds ] in
-                  $expr$
-                >>
-              in
-              patt, expr
+          let emit () =
+            let patt = mk_rec_patt loc patt name in
+            let vname = <:expr@loc< $lid:"v_" ^ name$ >> in
+            let cnv_expr = unroll_cnv_fp loc vname (sexp_of_type tp) in
+            let expr =
+              <:expr@loc<
+                let arg = $cnv_expr$ in
+                let bnd =
+                  Sexplib.Sexp.List [Sexplib.Sexp.Atom $str:name$; arg]
+                in
+                let bnds = [ bnd :: bnds ] in
+                $expr$
+              >>
+            in
+            patt, expr
+          in
+          begin match Pa_type_conv.Gen.find_record_default loc with
+          | None -> emit ()
+          | Some default ->
+              match get_record_field_handler loc with
+              | `keep -> emit ()
+              | `drop -> sexp_of_default_field patt expr name tp default
+              | `drop_if test -> sexp_of_record_field patt expr name tp test
           end
       | _ -> assert false  (* impossible *)
     in
               | <:ctyp@loc< sexp_array $_$ >>
               | <:ctyp@loc< mutable sexp_array $_$ >> -> mk_default loc
               | <:ctyp@loc< $_$ >> ->
-                  match Record_defaults.lookup loc with
+                  match Pa_type_conv.Gen.find_record_default loc with
                   | Some _ -> mk_default loc
                   | None ->
                       has_nonopt_fields := true;
               >>
           | <:ctyp@loc< $lid:nm$ : mutable $_$ >>
           | <:ctyp@loc< $lid:nm$ : $_$ >> ->
-              begin match Record_defaults.lookup loc with
+              begin match Pa_type_conv.Gen.find_record_default loc with
               | None -> <:rec_binding@loc< $lid:nm$ = $lid:nm ^ "_value"$ >>
-              | Some (default, _) ->
+              | Some default ->
                   <:rec_binding@loc<
                     $lid:nm$ =
                       match $lid:nm ^ "_value"$ with
         $Generate_of_sexp.of_sexp tds$; $Generate_sexp_of.sexp_of tds$
       >>
     )
-
-EXTEND Gram
-  GLOBAL: label_declaration;
-
-  label_declaration:
-    [[
-          s = a_LIDENT; ":"; t = poly_type;
-          "sexp_default"; "("; e = expr; ")" ->
-            Record_defaults.add _loc e;
-            <:ctyp< $lid:s$ : $t$ >>
-        | "mutable"; s = a_LIDENT; ":"; t = poly_type;
-          "sexp_default"; "("; e = expr; ")" ->
-            Record_defaults.add _loc e;
-            <:ctyp< $lid:s$ : mutable $t$ >>
-        | s = a_LIDENT; ":"; t = poly_type;
-          "sexp_default"; "("; e = expr; ")"; "!" ->
-            Record_defaults.add _loc ~do_not_emit:true e;
-            <:ctyp< $lid:s$ : $t$ >>
-        | "mutable"; s = a_LIDENT; ":"; t = poly_type;
-          "sexp_default"; "("; e = expr; ")"; "!" ->
-            Record_defaults.add _loc ~do_not_emit:true e;
-            <:ctyp< $lid:s$ : mutable $t$ >>
-    ]];
-END

File base/type_conv/syntax/pa_type_conv.ml

 (* Map of "with"-generators for exceptions in signatures *)
 let sig_exn_generators = Hashtbl.create 0
 
-(* Check that there is no argument for generators that do not expect
-   arguments *)
-let no_arg id e typ arg =
+(* Map of "with"-generators for record fields *)
+type record_generator = Loc.t -> unit
+
+let record_generators = Hashtbl.create 0
+
+(* Check that there is no argument for generators that do not expect any *)
+let no_arg id e arg typ =
   if arg = None then e typ
   else
     failwith (
 let safe_add_gen gens id entry e =
   if Hashtbl.mem gens id then
     failwith ("Pa_type_conv: generator '" ^ id ^ "' defined multiple times")
-  else Hashtbl.add gens id (fun typ arg -> e typ (parse_with entry arg))
+  else Hashtbl.add gens id (fun arg typ -> e (parse_with entry arg) typ)
 
 (* Register a "with"-generator for types in structures *)
 let add_generator_with_arg ?(is_exn = false) id entry e =
 let add_generator ?is_exn id e =
   add_generator_with_arg ?is_exn id ignore_tokens (no_arg id e)
 
-(* Removes a "with"-generator for types in structures *)
+(* Remove a "with"-generator for types in structures *)
 let rm_generator ?(is_exn = false) id =
   let gens = if is_exn then exn_generators else generators in
   Hashtbl.remove gens id
 let add_sig_generator ?is_exn id e =
   add_sig_generator_with_arg ?is_exn id ignore_tokens (no_arg id e)
 
-(* Removes a "with"-generator for types in signatures *)
+(* Remove a "with"-generator for types in signatures *)
 let rm_sig_generator ?(is_exn = false) id =
   let gens = if is_exn then sig_exn_generators else sig_generators in
   Hashtbl.remove gens id
 
+(* Register a "with"-generator for record fields *)
+let add_record_generator_with_arg id entry e =
+  safe_add_gen record_generators id entry e
+
+let add_record_generator id e =
+  add_record_generator_with_arg id ignore_tokens (no_arg id e)
+
+(* Remove a "with"-generator for record fields *)
+let rm_record_generator id = Hashtbl.remove record_generators id
+
 
 (* General purpose code generation module *)
 
 module Gen = struct
+  (* Map of record field source locations to their default expression *)
+  let record_defaults = Hashtbl.create 0
+
+  let find_record_default loc =
+    try Some (Hashtbl.find record_defaults loc) with Not_found -> None
+
   let gensym =
     let cnt = ref 0 in
     fun ?(prefix = "_x") () ->
 
 (* Functions for interpreting derivation types *)
 
-let find_generator ~name haystack = (); fun tp (needle, arg) ->
+let find_generator ~name haystack = (); fun entry (needle, arg) ->
   let genf =
     try Hashtbl.find haystack needle
     with Not_found ->
       in
       failwith msg
   in
-  genf tp arg
+  genf arg entry
 
 let generate = find_generator ~name:"type" generators
 
   let coll drv der_sis = <:sig_item< $der_sis$; $sig_generate tp drv$ >> in
   List.fold_right coll drvs (SgNil _loc)
 
-let sig_exn_generate = find_generator ~name:"signature exception" sig_exn_generators
+let sig_exn_generate =
+  find_generator ~name:"signature exception" sig_exn_generators
 
 let gen_derived_exn_sigs _loc tp drvs =
   let coll drv der_sis = <:sig_item< $der_sis$; $sig_exn_generate tp drv$ >> in
   List.fold_right coll drvs (SgNil _loc)
 
+let remember_record_generators el drvs =
+  let act drv =
+    let gen = find_generator ~name:"record field" record_generators in
+    gen el drv
+  in
+  List.iter act drvs
+
 
 (* Syntax extension *)
 
 DELETE_RULE Gram str_item: "module"; a_UIDENT; module_binding0 END;
 
 EXTEND Gram
-  GLOBAL: str_item sig_item;
+  GLOBAL: str_item sig_item label_declaration;
 
   str_item:
     [[
         <:str_item< exception $tds$; $gen_derived_exn_defs _loc tds drvs$ >>
     ]];
 
+  str_item:
+    [[
+      "module"; i = found_module_name; mb = module_binding0 ->
+        pop_conv_path ();
+        <:str_item< module $i$ = $mb$ >>
+    ]];
+
   sig_item:
     [[
       "type"; tds = type_declaration; "with"; drvs = LIST1 generator SEP "," ->
     ]];
 
   sig_item:
-   [[
-     "exception"; cd = constructor_declaration; "with";
-     drvs = LIST1 generator SEP "," ->
-       set_conv_path_if_not_set _loc;
-       <:sig_item< exception $cd$; $gen_derived_exn_sigs _loc cd drvs$ >>
+    [[
+      "exception"; cd = constructor_declaration; "with";
+      drvs = LIST1 generator SEP "," ->
+        set_conv_path_if_not_set _loc;
+        <:sig_item< exception $cd$; $gen_derived_exn_sigs _loc cd drvs$ >>
     ]];
 
-  str_item:
+  label_declaration:
     [[
-      "module"; i = found_module_name; mb = module_binding0 ->
-        pop_conv_path ();
-        <:str_item< module $i$ = $mb$ >>
+      name = a_LIDENT; ":"; tp = poly_type;
+      "with"; drvs = LIST1 generator SEP "," ->
+        remember_record_generators _loc drvs;
+        <:ctyp< $lid:name$ : $tp$ >>
+    | "mutable"; name = a_LIDENT; ":"; tp = poly_type;
+      "with"; drvs = LIST1 generator SEP "," ->
+        remember_record_generators _loc drvs;
+        <:ctyp< $lid:name$ : mutable $tp$ >>
     ]];
+END
 
-END
+(* Record field defaults *)
+
+(* Add "default" to set of record field generators *)
+let () =
+  add_record_generator_with_arg "default" Syntax.expr
+    (fun expr_opt loc ->
+      let default =
+        match expr_opt with
+        | Some expr -> expr
+        | None -> Loc.raise loc (Failure "could not parse expression")
+      in
+      Hashtbl.replace Gen.record_defaults loc default)

File base/type_conv/syntax/pa_type_conv.mli

 
 (** {6 Generator registration} *)
 
+val set_conv_path_if_not_set : Loc.t -> unit
+(** [set_conv_path_if_not_set loc] sets the path to the file/module being
+    converted for improved error messages. *)
+
+val get_conv_path : unit -> string
+(** [get_conv_path ()] @return the name to module containing a type
+    as required for error messages. *)
+
 val add_generator : ?is_exn : bool -> string -> (ctyp -> str_item) -> unit
 (** [add_generator ?is_exn name gen] adds the code generator [gen],
     which maps type or exception declarations to structure items, where
 
 val add_generator_with_arg :
   ?is_exn : bool -> string -> 'a Camlp4.PreCast.Gram.Entry.t ->
-  (ctyp -> 'a option -> str_item) -> unit
+  ('a option -> ctyp -> str_item) -> unit
 (** [add_generator_with_arg ?is_exn name entry generator] same as
     [add_generator], but the generator may accept an argument, which is
     parsed with [entry]. *)
 
 val rm_generator : ?is_exn : bool -> string -> unit
-(** [rm_generator ?is_exn name] removes the code generator named [name]. *)
-
-val add_sig_generator :
-  ?is_exn : bool -> string -> (ctyp -> sig_item) -> unit
-(** [add_generator ?is_exn name gen] adds the code generator [gen],
-    which maps type or exception declarations to signature items, where
-    [is_exn] specifies whether the declaration is an exception.  Note that
-    the original type/exception declarations get added automatically in
-    any case.
+(** [rm_generator ?is_exn name] removes the code generator named [name]
+    for types if [is_exn] is [false], or exceptions otherwise.
 
     @param is_exn = [false]
 *)
 
-val set_conv_path_if_not_set : Loc.t -> unit
+val add_sig_generator :
+  ?is_exn : bool -> string -> (ctyp -> sig_item) -> unit
+(** [add_sig_generator ?is_exn name gen] adds the code generator [gen],
+    which maps type or exception declarations to signature items, where
+    [is_exn] specifies whether the declaration is an exception.  Note that the
+    original type/exception declarations get added automatically in any case.
+
+    @param is_exn = [false]
+*)
 
 val add_sig_generator_with_arg :
   ?is_exn : bool -> string -> 'a Camlp4.PreCast.Gram.Entry.t ->
-  (ctyp -> 'a option -> sig_item) -> unit
+  ('a option -> ctyp -> sig_item) -> unit
 (** [add_sig_generator_with_arg ?is_exn name entry generator] same as
     [add_sig_generator], but the generator may accept an argument,
     which is parsed with [entry]. *)
 
 val rm_sig_generator : ?is_exn : bool -> string -> unit
-(** [rm_sig_generator name] removes the code signature generator named
+(** [rm_sig_generator ?is_exn name] removes the signature code generator named
+    [name] for types if [is_exn] is [false], or exceptions otherwise.
+
+    @param is_exn = [false]
+*)
+
+(** Type of record code generators *)
+type record_generator = Loc.t -> unit
+
+val add_record_generator : string -> record_generator -> unit
+(** [add_record_generator gen_name gen] adds the record field code generator
+    [gen_name], which acts on a record field location [loc], a record field
+    [name], and the record field type [tp]. *)
+
+val add_record_generator_with_arg :
+  string -> 'a Camlp4.PreCast.Gram.Entry.t ->
+  ('a option -> record_generator) -> unit
+(** [add_record_generator_with_arg name entry generator] same as
+    [add_record_generator], but the generator may accept an argument, which
+    is parsed with [entry]. *)
+
+val rm_record_generator : string -> unit
+(** [rm_record_generator name] removes the record field code generator named
     [name]. *)
 
-val get_conv_path : unit -> string
-(** [get_conv_path ()] @return the name to module containing a type
-    as required for error messages. *)
-
 
 (** {6 Utility functions} *)
 
   val drop_variance_annotations : ctyp -> ctyp
   (** [drop_variance_annotations tp] @return the type resulting from dropping
       all variance annotations in [tp]. *)
+
+  val find_record_default : Loc.t -> expr option
+  (** [find_record_default loc] @return the optional default expression
+      associated with the record field at source location [loc] if defined. *)
 end