On Sat, Oct 3, 2009 at 2:16 PM, Anil Madhavapeddy <anil@recoil.org> wrote:
> The only thing I haven't quite worked out yet is the quotation to
> pattern-match type applications to detect things like "(string, unit)
> Hashtbl.t" the way the current json-static does via the grammar extension.
> -anil

Below are two patches (from `git log -u`) adding the relevant features.

##########################
diff --git a/json-static/pa_json_tc.ml b/json-static/pa_json_tc.ml
index f1d21e7..09b7937 100644
--- a/json-static/pa_json_tc.ml
+++ b/json-static/pa_json_tc.ml
@@ -494,11 +494,15 @@ and process_td _loc = function
  | <:ctyp< int64 >> -> Int64
  | <:ctyp< unit >> -> Unit
  | <:ctyp< char >> -> Char
+ | <:ctyp< number >> -> Number

  | <:ctyp< option $t$ >> -> Option (_loc, process_td _loc t)
  | <:ctyp< list $t$ >> -> List (_loc, process_td _loc t)
  | <:ctyp< array $t$ >> -> Array (_loc, process_td _loc t)
-
+ | <:ctyp< assoc $t$ >> as assoc ->
+   (match t with
+      | <:ctyp< (string * $t$) >> -> Assoc (_loc, process_td _loc t)
+      | _ -> failwith "must be of the form (string * ...) assoc")
  | <:ctyp< < $cs$ > >> -> Object (process_fields _loc cs)
  | <:ctyp< { $cs$ } >> -> Record (process_fields _loc cs)

@@ -512,8 +516,13 @@ and process_td _loc = function
        (Ast.list_of_ctyp tp []) in
    Tuple tps

- | <:ctyp< $uid:id$.t >> -> Custom id (* XXX broken, how to check for TyApp? *)
+ | <:ctyp< Hashtbl.t string $x$ >> -> Hashtbl (_loc, process_td _loc x)
+ | <:ctyp< json_type >>
+ | <:ctyp< Json_type.json_type >>
+ | <:ctyp< Json_type.t >>
+   -> Raw
  | <:ctyp< $lid:id$ >> -> Name id
+ | <:ctyp< $uid:id$.t >> -> Custom id
  | _ -> failwith "unknown type"

 open Pa_type_conv


##########################
diff --git a/json-static/check.ml b/json-static/check.ml
index 19bac81..ff0186b 100644
--- a/json-static/check.ml
+++ b/json-static/check.ml
@@ -33,3 +33,4 @@ and b = int

 type json c = (string * d * d) list
 and d = [ `A ]
+
diff --git a/json-static/check_tc.ml b/json-static/check_tc.ml
index b362ad2..3105800 100644
--- a/json-static/check_tc.ml
+++ b/json-static/check_tc.ml
@@ -31,3 +31,6 @@ let _ =
   assert (json_o#foo = o#foo);
   assert (json_o#bar = o#bar);
   prerr_endline json_string
+
+type c = (string, unit) Hashtbl.t with json
+type d = (string * float) assoc with json
diff --git a/json-static/pa_json_tc.ml b/json-static/pa_json_tc.ml
index 09b7937..5c76819 100644
--- a/json-static/pa_json_tc.ml
+++ b/json-static/pa_json_tc.ml
@@ -448,6 +448,9 @@ let expand_typedefs _loc l =
   let tojson = make_tojson _loc l in
   <:str_item< $ofjson$; $tojson$ >>

+let type_fail ctyp msg =
+  Loc.raise (Ast.loc_of_ctyp ctyp) (Failure msg)
+
 let rec process_tds tds =
   let rec fn ty =
     match ty with
@@ -455,7 +458,7 @@ let rec process_tds tds =
        fn tyl @ (fn tyr)
     |Ast.TyDcl (_loc, id, _, ty, []) ->
        [ (_loc, id ) , (_loc, process_td _loc ty) ]
-    |_ -> failwith "process_tds: unexpected type"
+    | other -> type_fail other "process_tds: unexpected AST"
    in fn tds

 and process_fields _loc cs =
@@ -463,7 +466,7 @@ and process_fields _loc cs =
     | <:ctyp< $t1$; $t2$ >> -> fn t1 @ (fn t2)
     | <:ctyp< $lid:id$ : mutable $t$ >> -> fnt ~mut:true ~id ~t
     | <:ctyp< $lid:id$ : $t$ >> ->  fnt ~mut:false ~id ~t
-    | _ -> failwith "unexpected ast"
+    | other -> type_fail other "process_fields: unexpected AST"
   and fnt ~mut ~id ~t =
     [ { field_caml_name = id; field_json_name = id;
         field_type = (_loc, process_td _loc t);
@@ -482,7 +485,7 @@ and process_constructor _loc rf =
     | <:ctyp< $uid:id$ >> ->
        { cons_caml_name=id; cons_json_name=id; cons_caml_loc=_loc;
          cons_json_loc=_loc; cons_args=[] }
-    | _ -> failwith "process_constructor: unexpected AST"
+    | other -> type_fail other "process_constructor: unexpected AST"
   ) (Ast.list_of_ctyp rf [])

 and process_td _loc = function
@@ -502,7 +505,7 @@ and process_td _loc = function
  | <:ctyp< assoc $t$ >> as assoc ->
    (match t with
       | <:ctyp< (string * $t$) >> -> Assoc (_loc, process_td _loc t)
-      | _ -> failwith "must be of the form (string * ...) assoc")
+      | other -> type_fail assoc "must be of the form (string * ...) assoc")
  | <:ctyp< < $cs$ > >> -> Object (process_fields _loc cs)
  | <:ctyp< { $cs$ } >> -> Record (process_fields _loc cs)

@@ -523,7 +526,7 @@ and process_td _loc = function
    -> Raw
  | <:ctyp< $lid:id$ >> -> Name id
  | <:ctyp< $uid:id$.t >> -> Custom id
- | _ -> failwith "unknown type"
+ | other -> type_fail other "unknown type"

 open Pa_type_conv
 let _ =