1. camlspotter
  2. meta_conv

Commits

camlspotter  committed 8c60238

added with conv(...) record field type_conv arg

  • Participants
  • Parent commits f8a82bd
  • Branches default

Comments (0)

Files changed (3)

File README.rst

View file
  • Ignore whitespace
 
       type t = { type_ as "type" : string } with conv(json)
 
+   You can also write the record tag name annotations in the form of type_conv record field arg ``conv(name("blah"))``::
+
+      type t = { type_ : string with conv(name("type")) } with conv(json)
+
 Special type names
 ========================================
 

File json/tests/test.ml

View file
  • Ignore whitespace
     assert (t_of_json (json_of_t' r') = `Ok { x = 1; y = 1.0 })
 end
 
+module Test51 = struct
+  type t (: Ignore_unknown_fields :) = { x : int; y : float } with conv (json)
+  type t' = { x' : int with conv(name "x"); y' : float with conv(name "y"); z' : unit with conv(name "z") } with conv (json)
+  
+  let () = 
+    let r' = { x' = 1; y' = 1.0; z' = () }  in
+    assert (t_of_json (json_of_t' r') = `Ok { x = 1; y = 1.0 })
+end
+
 module Test6 = struct
   type t = { x : int; y : float; rest : Json.t mc_leftovers; } with conv (json)
   type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (json)
 
 end
 
+module TestConv = struct
+  type t = { x : int with conv(json_of( fun x -> json_of_string (string_of_int x) ), 
+                               of_json( fun ?trace j -> Meta_conv.Result.fmap int_of_string (string_of_json ?trace j) )) 
+            } with conv(json)
+  
+  let () =
+    assert (t_of_json (json_of_t {x = 10}) = `Ok {x = 10})
+end
+

File pa/pa_meta_conv.ml

View file
  • Ignore whitespace
 
 open Tctools
 
+let failwithf fmt = Printf.ksprintf failwith fmt
+
 (* syntax modification **************************************************)
 
- open Syntax
+open Syntax
 
 let annotations = Hashtbl.create 31
 
   
   constructor_declaration: 
       [ [ s = a_UIDENT; "(:"; e = expr; ":)"; "of"; t = constructor_arg_list ->
-            Hashtbl.add annotations (_loc,s) e;
+            Hashtbl.add annotations _loc e;
             <:ctyp< $uid:s$ of $t$ >>
         | s = a_UIDENT; "as"; n = a_STRING; "of"; t = constructor_arg_list ->
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             <:ctyp< $uid:s$ of $t$ >>
         | s = a_UIDENT; "(:"; e = expr; ":)" ->
-            Hashtbl.add annotations (_loc,s) e;
+            Hashtbl.add annotations _loc e;
             <:ctyp< $uid:s$ >>
         | s = a_UIDENT; "as"; n = a_STRING ->
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             <:ctyp< $uid:s$ >>
       ] ];
 
   constructor_declarations:
       [ [ s = a_UIDENT; "(:"; e = expr; ":)"; "of"; t = constructor_arg_list ->
-            Hashtbl.add annotations (_loc,s) e;
+            Hashtbl.add annotations _loc e;
             <:ctyp< $uid:s$ of $t$ >>
         | s = a_UIDENT; "as"; n = a_STRING; "of"; t = constructor_arg_list ->
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             <:ctyp< $uid:s$ of $t$ >>
         | s = a_UIDENT; "(:"; e = expr; ":)" ->
-            Hashtbl.add annotations (_loc,s) e;
+            Hashtbl.add annotations _loc e;
             <:ctyp< $uid:s$ >>
         | s = a_UIDENT; "as"; n = a_STRING ->
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             <:ctyp< $uid:s$ >>
       ] ];
 
   row_field:
       [ [ "`"; i = a_ident; "(:"; e = expr; ":)" -> 
-           Hashtbl.add annotations (_loc,i) e;
+           Hashtbl.add annotations _loc e;
            <:ctyp< `$i$ >>
         | "`"; i = a_ident; "as"; n = a_STRING -> 
-           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           Hashtbl.add annotations _loc <:expr< $str:n$ >>;
            <:ctyp< `$i$ >>
         | "`"; i = a_ident; "(:"; e = expr; ":)"; "of"; "&"; t = amp_ctyp -> 
-           Hashtbl.add annotations (_loc,i) e;
+           Hashtbl.add annotations _loc e;
            <:ctyp< `$i$ of & $t$ >>
         | "`"; i = a_ident; "as"; n = a_STRING; "of"; "&"; t = amp_ctyp -> 
-           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           Hashtbl.add annotations _loc <:expr< $str:n$ >>;
            <:ctyp< `$i$ of & $t$ >>
         | "`"; i = a_ident; "(:"; e = expr; ":)"; "of"; t = amp_ctyp -> 
-           Hashtbl.add annotations (_loc,i) e;
+           Hashtbl.add annotations _loc e;
            <:ctyp< `$i$ of $t$ >>
         | "`"; i = a_ident; "as"; n = a_STRING; "of"; t = amp_ctyp -> 
-           Hashtbl.add annotations (_loc,i) <:expr< $str:n$ >>;
+           Hashtbl.add annotations _loc <:expr< $str:n$ >>;
            <:ctyp< `$i$ of $t$ >>
       ] ]
     ;
 
   label_declaration:
     [ [ s = a_LIDENT; "(:"; e = expr; ":)"; ":"; t = poly_type ->  
-            Hashtbl.add annotations (_loc,s) e;
+            Hashtbl.add annotations _loc e;
             (* dont know why but it is impos to write 
                <:ctyp< $lid:s$ : $t$ >> *)
             TyCol (_loc, 
                    TyId(_loc, <:ident< $lid:s$ >> ), 
                    t )
+      | "mutable"; s = a_LIDENT; "(:"; e = expr; ":)"; ":"; t = poly_type ->  
+            Hashtbl.add annotations _loc e;
+            (* dont know why but it is impos to write 
+               <:ctyp< $lid:s$ : $t$ >> *)
+            TyCol (_loc, 
+                   TyId(_loc, <:ident< $lid:s$ >> ), 
+                   TyMut(_loc, t) )
       | s = a_LIDENT; "as"; n = a_STRING; ":"; t = poly_type ->  
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             (* dont know why but it is impos to write 
                <:ctyp< $lid:s$ : $t$ >> *)
             TyCol (_loc, 
                    TyId(_loc, <:ident< $lid:s$ >> ), 
                    t )
       | "mutable"; s = a_LIDENT; "as"; n = a_STRING; ":"; t = poly_type ->
-            Hashtbl.add annotations (_loc,s) <:expr< $str:n$ >>;
+            Hashtbl.add annotations _loc <:expr< $str:n$ >>;
             (* dont know why but it is impos to write 
                <:ctyp< $lid:s$ : $t$ >> *)
             TyCol (_loc,
   type_declaration:
     [ [ (n, tpl) = type_ident_and_parameters; "(:"; e = expr; ":)"; tk = opt_eq_ctyp;
         cl = LIST0 constrain -> 
-          Hashtbl.add annotations (_loc,n) e;
+          Hashtbl.add annotations _loc e;
           Ast.TyDcl(_loc, n, tpl, tk, cl)
     ] ];
 
   meth_decl:
       [ [ lab = a_LIDENT; "(:"; e = expr; ":)"; ":"; t = poly_type -> 
-          Hashtbl.add annotations (_loc, lab) e;
+          Hashtbl.add annotations _loc e;
           TyCol (_loc, 
                  TyId(_loc, <:ident< $lid:lab$ >> ), 
                  t )
         | lab = a_LIDENT; "as"; n = a_STRING; ":"; t = poly_type -> 
-          Hashtbl.add annotations (_loc, lab) <:expr< $str:n$ >>;
+          Hashtbl.add annotations _loc <:expr< $str:n$ >>;
           TyCol (_loc, 
                  TyId(_loc, <:ident< $lid:lab$ >> ), 
                  t )
   ignore_unknown_fields = false;
 }
 
-let interprete_record_type_name_annotation loc name = 
+(* Search is done purely by location. Not with name *)
+let interprete_record_type_name_annotation loc _name = 
   let annots = 
-    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations (loc, name)))
+    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations loc))
   in
   List.fold_left (fun _acc -> function
     | <:expr< Ignore_unknown_fields >> -> { ignore_unknown_fields = true }
   one_of = false;
 }
 
-let interprete_variant_type_name_annotation loc name = 
+(* Search is done purely by location. Not with name. *)
+let interprete_variant_type_name_annotation loc _name = 
   let annots = 
-    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations (loc, name)))
+    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations loc))
   in
   List.fold_left (fun _acc -> function
     | <:expr< one_of >> -> { one_of = true }
     annots
 
 let interprete_variant_annotation loc id_name = 
-  match Hashtbl.find_all annotations (loc, id_name) with
+  match Hashtbl.find_all annotations loc with
   | [ <:expr< $str:x$ >> ] -> x
   | [] -> id_name
   | _ -> failwith "strange meta_conv variant annotation"
       optional : ctyp option; (* t mc_option => Some t *)
       leftovers : bool;
       embeded : ([ `Embeded | `Option_embeded ] * ctyp) option; (* t mc_embeded *)
+      encoder: expr option;
+      decoder: expr option;
     }
 
-let interprete_record_field_annotation target_type_path loc id ctyp = 
+let interprete_record_field_annotation conv_name target_type_path loc id ctyp = 
   let name = name_of_ident id  in
   let optional = match ctyp with
     | <:ctyp< $t$ mc_option >>
     | _ -> None
   in
   let annots = 
-    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations (loc, name)))
+    List.flatten (List.map split_by_comma (Hashtbl.find_all annotations loc))
   in
-  let st0 = { name; optional; leftovers; embeded } in
+  let st0 = { name; optional; leftovers; embeded; encoder= None; decoder= None } in
+  let f st = function
+    | <:expr< $str:x$ >> -> { st with name = x }
+    | <:expr< $lid:x$ ($e$) >> when x = conv_name ^ "_of" ->
+        if st.encoder <> None then failwithf "more than one %s are specified" x;
+        { st with encoder = Some e }
+    | <:expr< $lid:x$ ($e$) >> when x = "of_" ^ conv_name ->
+        if st.encoder <> None then failwithf "more than one %s are specified" x;
+        { st with decoder = Some e }
+    | _ -> prerr_endline "Unknown (: .. :) meta_conv annotation"; assert false
+  in
   List.fold_left (fun st -> function
-    | <:expr< $str:x$ >> -> { st with name = x }
-    | _ -> prerr_endline "Unknown (: .. :) meta_conv annotation"; assert false) st0 annots
+    | ExTup (_, expr) ->
+        List.fold_left f st (list_of_expr expr [])
+    | e -> f st e) st0 annots
 
 (* code generators ******************************************************)
 
     in
     let fields = List.fold_right (fun (loc, lab_id, ctyp) fields ->
       let f = gen_ctyp (strip_field_flags ctyp) in
-      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      let sem = interprete_record_field_annotation conv_name target_type_path loc lab_id ctyp in
       match sem with
       | { leftovers = true; embeded = Some _; _ } -> assert false
 
       | { leftovers = true; _ } -> 
           accessor lab_id :: fields
 
+      | { embeded = Some _; encoder = Some _; _ } 
+      | { optional = Some _; encoder = Some _; _ } -> 
+          failwithf "%s: label %s is specified both with a custom encoder and special handling type. It is not possible."
+            (Loc.to_string loc)
+            (name_of_ident lab_id)
+
       | { embeded = Some (`Embeded, ctyp); _ } -> 
           let f = gen_ctyp (strip_field_flags ctyp) in
           <:expr< $decode_exn$ 
                   | None -> [] 
                   | Some v -> [($str:s$, $f$ v)] >>
           :: fields
+
+      | { name = s; encoder = Some f'; _ } -> 
+          <:expr< [ ($str:s$, $f'$ $accessor lab_id$) ] >> :: fields
+
       | { name = s; _ } ->
           <:expr< [ ($str:s$, $f$ $accessor lab_id$) ] >> :: fields) field_types []
+
     in
     let exp = <:expr< List.flatten $create_list fields$ >> in
     <:expr< (fun __v -> $creator$ $exp$) >>
 
     let primary, embeded, leftovers = List.fold_right (fun (loc, lab_id, ctyp) 
       (primary, embeded, leftovers) ->
-      let sem = interprete_record_field_annotation target_type_path loc lab_id ctyp in
+      let sem = interprete_record_field_annotation conv_name target_type_path loc lab_id ctyp in
       let ctyp = strip_field_flags ctyp in
       match sem with
       | { leftovers = true; embeded = Some _; _ }-> assert false
           if leftovers <> None then errorf loc "Only one field with mc_leftovers is allowed";
           primary, embeded, Some lab_id
 
+      | { embeded = Some _; decoder = Some _; _ }
+      | { optional = Some _; decoder = Some _; _ } ->
+          failwithf "%s: label %s is specified both with a custom encoder and special handling type. It is not possible."
+            (Loc.to_string loc)
+            (name_of_ident lab_id)
+
       | { embeded = Some ctyp; _ }-> 
           primary, (lab_id, ctyp) :: embeded, leftovers
 
       | { name=key; optional = Some ctyp; _ } -> 
           (lab_id, key, `Optional ctyp) :: primary, embeded, leftovers
 
+      | { name=key; decoder= Some d; _ } -> 
+          (lab_id, key, `Custom d) :: primary, embeded, leftovers
+
       | { name=key; _ } -> 
           (lab_id, key, `Normal ctyp) :: primary, embeded, leftovers)
       field_types ([], [], None)
                   ($id:module_path$.exn $conv$) 
                   ?trace:(Some __t) __v
             >>
-              
+
+        | `Custom conv ->
+            <:binding< 
+              $id:lab_id$ = 
+                Meta_conv.Internal.field_assoc_exn 
+                  __name 
+                  $str:key$ 
+                  primary_fields 
+                  $id:module_path$.throw
+                  ($id:module_path$.exn $conv$) 
+                  ?trace:(Some __t) __v
+            >>
+
         | `Normal ctyp ->
             let conv = gen_ctyp ctyp in
 
         (if List.mem `Encode dirs then [Encode.sg rec_ tds] else [])
         @ (if List.mem `Decode dirs then [Decode.sg rec_ tds] else [])) 
                       (parse_argopt argopt))
-    end)
+    end);
+
+  Pa_type_conv.add_record_field_generator_with_arg "conv"
+    Syntax.expr (fun expr_opt tp ->
+      let loc = Ast.loc_of_ctyp tp in
+      let f = function
+        | <:expr< name( $e$ ) >> -> 
+            begin match e with
+            | <:expr< $str:_$ >> -> Hashtbl.add annotations loc e
+            | _ -> failwith "conv(name(x)) requires a string argument"
+            end
+        | e -> Hashtbl.add annotations loc e
+      in
+      match expr_opt with
+      | None -> failwith "conv(x,y,..) requires arugments"
+      | Some (ExTup (_, expr)) -> List.iter f (list_of_expr expr [])
+      | Some e -> f e)