]> 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 _ =