Commits

Anonymous committed de25351

Cd_Json.from_json: + Sum_type

  • Participants
  • Parent commits 1e9ca07

Comments (0)

Files changed (1)

File src/cd_Json.ml

 ;
 
 
+(* mapping constructor names from rtti to string for json *)
+
+value map_ctr_name vname =
+  let vname = String.lowercase vname in
+  let vname = String.chop_prefix ~string:vname ~prefix:"`" in
+  vname
+;
+
+(* check if constructor's name [con] was created by [map_ctr_name vname] *)
+
+value is_mapped_ctr_name ~con ~vname =
+  let con_len = String.length con
+  and vname_len = String.length vname in
+  let vi =
+    if vname_len > 0 && vname.[0] = '`'
+    then 1
+    else 0
+  in
+  if vname_len - vi <> con_len
+  then
+    False
+  else
+    loop 0
+    where rec loop i =
+      if i = con_len
+      then True
+      else
+        let con_ch = con.[i]
+        and vname_ch = vname.[vi + i] in
+        let is_eq =
+          if i = 0
+          then Char.lowercase con_ch = Char.lowercase vname_ch
+          else con_ch = vname_ch
+        in
+          if is_eq
+          then loop (i + 1)
+          else False
+;
+
+
+
 
 value to_json_struc
  : #ti 'a -> (ubox -> ubox)  (* a -> Json_type.t *)
         fun u ->
           let (vname, disp) = destr u in
           let uarr = disp "json.to" in
-          let jargs = Array.map_to_list ubox_to_json uarr
-          in
-          let vname = String.lowercase vname in
-          let vname = String.chop_prefix ~string:vname ~prefix:"`" in
+          let jargs = Array.map_to_list ubox_to_json uarr in
+          let vname = map_ctr_name vname in
           ubox ti_json (Bl.array [Bl.string vname :: jargs])
 
     | Record_type _ _ _ _
            in
            constr ufields
 
-       | Sum_type _destr _constr
-           -> failwith "json.from: Sum_type: not implemented"
-           
+       | Sum_type _destr constr -> fun j ->
+           let jlst = Br.array j in
+           match jlst with
+           [ [] -> failwith "json.from: Sum_type: empty array"
+           | [jcon :: jargs] ->
+               let con = Br.string jcon in
+               let constr_len = Array.length constr in
+               find_constr 0
+               where rec find_constr i =
+                 if i = constr_len
+                 then
+                   failwith "json.from: Sum_type: no such constructor: %S"
+                     con
+                 else
+                   let (vname, utis, construct) = constr.(i) in
+                   if is_mapped_ctr_name ~con ~vname
+                   then
+                     let jargs_arr = Array.of_list jargs in
+                     let jargs_arr_len = Array.length jargs_arr
+                     and utis_len = Array.length utis in
+                     if jargs_arr_len <> utis_len
+                     then
+                       failwith "json.from: Sum_type: constructor %S requires \
+                                 %i arguments, json has %i arguments"
+                         con utis_len jargs_arr_len
+                     else
+                       construct &
+                       Array.map2to1
+                         ubox_from_json
+                         utis
+                         jargs_arr
+                   else
+                     find_constr (i + 1)
+           ]
+
        | Tuple _destr utis constr ->
            fun j ->
            let jarr = Array.of_list (Br.array j) in