On Sat, Oct 3, 2009 at 2:16 PM, Anil Madhavapeddy <a...@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 _ =
_______________________________________________
Caml-list mailing list. Subscription management:
http://yquem.inria.fr/cgi-bin/mailman/listinfo/caml-list
Archives: http://caml.inria.fr
Beginner's list: http://groups.yahoo.com/group/ocaml_beginners
Bug reports: http://caml.inria.fr/bin/caml-bugs
