Commits

camlspotter committed a3ba865 Draft

type_conv 108.07.00 has a bug, and we needed a workaround for pattern type constraints

  • Participants
  • Parent commits 7e8d1bc

Comments (0)

Files changed (3)

   lib/pa_json_tc.ml
 
 $(Installed json-tc-custom): $(Installed type_conv) $(SOURCES)
-  (cd lib/; make uninstall all install; spotinstall json-tc-custom)
+  (cd lib/; make uninstall all install) # we cannot have spotinstall here, since it ignores the error of make.
+  (cd lib/; spotinstall json-tc-custom)
   CreateInstalled(json-tc-custom, $(find $(OCAMLFIND_DESTDIR)$(DIRSEP)json-tc-custom -f {}))
 
+.DEFAULT: $(Installed json-tc-custom)
+
+install: $(Installed json-tc-custom)
+
 clean:
   (cd lib; make clean)

File lib/META.template

-name = "json-tc"
+name = "json-tc-custom"
 description = "statically-typed JSON data using type_conv"
 
 package "syntax" (

File lib/pa_json_tc.ml

 	 (*if x.is_private then acc
 	 else*)
 	   let fname = name ^ "_of_json" in
-           <:binding< ( $lid:fname$ : Json_type.t -> $lid:name$ ) = 
-                      $eta_expand (convert x)$ and $acc$ >>)
-      l <:binding<>>
+(*
+           <:binding< ( $lid:fname$ : Json_type.t -> $lid:name$ ) = $eta_expand (convert x)$ and $acc$ >>)
+*)
+           <:binding< $lid:fname$ = $eta_expand (convert x)$ and $acc$ >>)
+      l <:binding< >>
   in
-    <:str_item< $error$; value rec $defs$ >>
+  <:str_item< $error$; value rec $defs$ >>
 
 let make_tojson _loc l =
   let build _loc s = <:expr< Json_type.Build. $lid:s$ >> in
   let defs = 
     List.fold_right
       (fun ((_loc, name), x) acc -> 
-	 let fname = "json_of_" ^ name in
-	 <:binding< ( $lid:fname$ : $lid:name$ -> Json_type.t ) =
-	            $eta_expand (convert x)$ and $acc$ >>)
+	let fname = "json_of_" ^ name in
+(*
+	<:binding< ( $lid:fname$ : $lid:name$ -> Json_type.t ) = $eta_expand (convert x)$ and $acc$ >>)
+*)
+	<:binding< $lid:fname$ = $eta_expand (convert x)$ and $acc$ >>)
       l <:binding<>> in
   <:str_item< value rec $defs$ >>
 
 let rec process_tds skips tds =
   let rec fn ty =
     match ty with
-    |Ast.TyAnd (_loc, tyl, tyr) ->
-       fn tyl @ (fn tyr)
-    |Ast.TyDcl (_loc, id, _, ty, []) ->
-       if List.mem id skips then [] else
-       [ (_loc, id ) , (_loc, process_td _loc ty) ]
+    | Ast.TyAnd (_loc, tyl, tyr) ->
+        fn tyl @ (fn tyr)
+    | Ast.TyDcl (_loc, id, _, ty, []) ->
+        if List.mem id skips then [] 
+        else [ (_loc, id ) , (_loc, process_td _loc ty) ]
     | other -> type_fail other "process_tds: unexpected AST"
-   in fn tds
+  in fn tds
 
 and process_fields _loc cs =
   let rec fn = function
 
 open Pa_type_conv
 let _ =
-  add_generator_with_arg 
-    ~is_exn:false 
+  add_generator_with_arg
     "json" 
     json_parms
     (fun args _bool (tds : Ast.ctyp) -> 
       let ptd = match args with
         | None -> process_tds [] tds
         | Some x -> 
-            let (skips : string list) = List.fold_left (fun a -> function | `Skip x -> a @ x) [] x in
-            process_tds skips tds in
+            let (skips : string list) = List.fold_left (fun a -> function | `Skip x -> a @ x) [] x 
+            in
+            process_tds skips tds 
+      in
       <:str_item< $expand_typedefs _loc ptd$ >>)
-