Commits

Anonymous committed 9581445

Cd_Ser: [de]ser.marshal uses common mechanism

Comments (0)

Files changed (2)

 
 (******************************************************)
 
+(*
+   [de]serialization has following methods, for [ti 'a]:
 
+   can.[de]ser : list string = ["marshal"; "json"; ..]
+   ser.<format> : a -> string
+   deser.<format> : string -> a  (* raises exceptions on failure *)
+*)
+
+open Cd_List;
+value ti_list_string = List.ti_list_string;
+
+value uti_add_format (uti : #uti) (meth_name : string) (format : string) =
+  let f_old =
+    try
+      get_meth_typed0 meth_name uti ti_list_string
+    with
+    [ Cdt.No _ _ -> [] ]
+  in
+  let f_new =
+    if List.mem format f_old
+    then failwith
+      "Cd_Ser: format %S already exists in method %S of typeinfo %S"
+      format meth_name uti#type_name
+    else
+      [format :: f_old]
+  in
+    Meths.replace meth_name (ubox ti_list_string f_new) uti#meths
+;
+
+
+value ti_gen_add_ser (ti : #ti 'a) (fmt : string) (ser : 'a -> string) =
+  ( uti_add_format ti "can.ser" fmt
+  ; uti_add_meth ti ("ser." ^ fmt) (ubox (ti_abs ti ti_string) ser)
+  )
+;
+
+value ti_gen_add_deser (ti : #ti 'a) (fmt : string) (deser : string -> 'a) =
+  ( uti_add_format ti "can.deser" fmt
+  ; uti_add_meth ti ("deser." ^ fmt) (ubox (ti_abs ti_string ti) deser)
+  )
+;
 
 
 
   =
     ( if ser
       then
-        uti_add_meth (ti :> uti) "ser.marshal" &
-          ubox (ti_abs ti ti_string) &
-            (ti_ser_td ti ti#type_desc)
+        ti_gen_add_ser ti "marshal" (ti_ser_td ti ti#type_desc)
       else ()
     ; if deser
       then
-        uti_add_meth (ti :> uti) "deser.marshal" &
-          ubox (ti_abs ti_string ti) &
-            (ti_deser_td ti ti#type_desc)
+        ti_gen_add_deser ti "marshal" (ti_deser_td ti ti#type_desc)
       else ()
     )
 ;
         value create : unit -> t;
         value add : meth_name -> R.ubox -> t -> unit;
         value get : meth_name -> t -> R.ubox;
+        value replace : meth_name -> R.ubox -> t -> unit;
       end
     ;
 
         value create : unit -> t;
         value add : meth_name -> R.ubox -> t -> unit;
         value get : meth_name -> t -> R.ubox;
+        value replace : meth_name -> R.ubox -> t -> unit;
       end
      =
       struct
           then raise Meth_exists
           else Hashtbl.add ht mn ub
         ;
+        value replace mn ub ht =
+          Hashtbl.replace ht mn ub
+        ;
         value get mn ht =
           try
             Hashtbl.find ht mn
 ;
 
 
+value get_meth_typed0
+ : meth_name -> #uti -> #ti 'a -> 'a
+ = fun mn u ta ->
+     let ua = get_meth_untyped mn u in
+     uget_exn ta ua
+;
+
 value get_meth_typed1
  : meth_name -> #uti -> #ti 'a -> #ti 'z -> ('a -> 'z)
  = fun mn u ta tz ->
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.