From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: X-Spam-Checker-Version: SpamAssassin 3.1.3 (2006-06-01) on yquem.inria.fr X-Spam-Level: ** X-Spam-Status: No, score=2.2 required=5.0 tests=AWL,DNS_FROM_RFC_POST, SPF_NEUTRAL autolearn=disabled version=3.1.3 X-Original-To: caml-list@yquem.inria.fr Delivered-To: caml-list@yquem.inria.fr Received: from mail3-relais-sop.national.inria.fr (mail3-relais-sop.national.inria.fr [192.134.164.104]) by yquem.inria.fr (Postfix) with ESMTP id 22B83BC37 for ; Sat, 3 Oct 2009 19:28:00 +0200 (CEST) X-IronPort-Anti-Spam-Filtered: true X-IronPort-Anti-Spam-Result: ApMBALomx0rRVdK2kGdsb2JhbACROYh9PwEBAQEJCQwHEwOmNYE7jlcBAwMFhCUEgVI X-IronPort-AV: E=Sophos;i="4.44,500,1249250400"; d="scan'208";a="35555725" Received: from mail-yx0-f182.google.com ([209.85.210.182]) by mail3-smtp-sop.national.inria.fr with ESMTP; 03 Oct 2009 19:27:59 +0200 Received: by yxe12 with SMTP id 12so2022825yxe.1 for ; Sat, 03 Oct 2009 10:27:58 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:mime-version:received:in-reply-to:references :date:message-id:subject:from:to:cc:content-type; bh=/mz4HS2skMDTMnV/f7EKg5oKuVcUAWv5AmsJxp2dg5U=; b=t33sjrdB6KFAaSJLMNgjxXCEU4IwlEWl/Ekt0nruOkTRxfQgtbaJB89d6BJc655BCU fiv7u5uc6+hi8BGEnNjUkslA1lIdwoMtbgBN1UDIEyBuWaMlRzNythlP4+hbwMvTjzyB Tdi+mMMBgHbMjdq2ZVruMlpQLTvLS2HjvO488= DomainKey-Signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=mime-version:in-reply-to:references:date:message-id:subject:from:to :cc:content-type; b=SguNO6joSCBW+0nMNMLloXoB+PPYRWTbTR5khjVTbfhcfiU3DZmhOXuAzVcQgrtQKu 52tquwY1eyDu+KKoXosuY4oW9wVN+uiDk9JPFUy+uCSaqq89aTRtbyX5xfCrpnma1xcL caroX4yzGpFck4XfK7Cv/jgEIQqKXSU1J9BXg= MIME-Version: 1.0 Received: by 10.101.81.15 with SMTP id i15mr4126063anl.131.1254590878456; Sat, 03 Oct 2009 10:27:58 -0700 (PDT) In-Reply-To: <205DBD56-053A-48B6-B37F-230FB49B7499@recoil.org> References: <46ACB6F9-FFAE-4C9C-9E46-21CA2E93434C@mykola.org> <20090923195713.GA12236@annexia.org> <001a01ca3ced$8ef58050$ace080f0$@metastack.com> <527cf6bc0909240245g11ce241cr16ac482003bb25f2@mail.gmail.com> <4ABB5597.9010805@ens-lyon.org> <527cf6bc0909240502p1292ca1fs5890d3efeac49531@mail.gmail.com> <4ABB63ED.1000402@ens-lyon.org> <205DBD56-053A-48B6-B37F-230FB49B7499@recoil.org> Date: Sat, 3 Oct 2009 19:27:57 +0200 Message-ID: <527cf6bc0910031027p2ef071bbue89260810fc337b6@mail.gmail.com> Subject: Re: [Caml-list] Generation of Java code from OCaml From: blue storm To: Anil Madhavapeddy Cc: Martin Jambon , caml-list@yquem.inria.fr Content-Type: text/plain; charset=ISO-8859-1 X-Spam: no; 0.00; ocaml:01 anil:01 anil:01 hashtbl:01 ctyp:01 ctyp:01 failwith:01 hashtbl:01 failwith:01 foo:01 foo:01 prerr:01 endline:01 typedefs:01 tyl:01 On Sat, Oct 3, 2009 at 2:16 PM, Anil Madhavapeddy 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 _ =