[Pkg-ocaml-maint-commits] [atdgen] 06/16: Imported Upstream version 1.6.1
Stéphane Glondu
glondu at moszumanska.debian.org
Thu Jan 28 10:29:23 UTC 2016
This is an automated email from the git hooks/post-receive script.
glondu pushed a commit to branch master
in repository atdgen.
commit 7137770108884a8b4488e4d6a0c35a901dccce23
Author: Stephane Glondu <steph at glondu.net>
Date: Thu Jan 28 09:51:50 2016 +0100
Imported Upstream version 1.6.1
---
src/Makefile | 2 +-
src/ag_mapping.ml | 27 +++++++++++++++++++++++++++
src/ag_ocaml.ml | 2 ++
src/ag_oj_emit.ml | 37 +++++++++++++++++++++++++------------
src/ag_oj_run.ml | 20 ++++++++++----------
test/test.atd | 2 ++
6 files changed, 67 insertions(+), 23 deletions(-)
diff --git a/src/Makefile b/src/Makefile
index 34916c7..0b064dd 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,4 +1,4 @@
-VERSION = 1.6.0
+VERSION = 1.6.1
ifeq "$(shell ocamlc -config |grep os_type)" "os_type: Win32"
EXE=.exe
else
diff --git a/src/ag_mapping.ml b/src/ag_mapping.ml
index df16bb3..e4ac141 100644
--- a/src/ag_mapping.ml
+++ b/src/ag_mapping.ml
@@ -181,3 +181,30 @@ let make_deref
Env.empty (flatten l) in
fun x -> deref_expr defs [] x
+
+(*
+ Resolve names and unwrap `wrap` constructs
+ (discarding annotations along the way)
+*)
+let rec unwrap (deref: ('a, 'b) mapping -> ('a, 'b) mapping) x =
+ match deref x with
+ | `Wrap (loc, x, a, b) -> unwrap deref x
+ | x -> x
+
+(* This is for debugging *)
+let constructor : ('a, 'b) mapping -> string = function
+ | `Unit _ -> "Unit"
+ | `Bool _ -> "Bool"
+ | `Int _ -> "Int"
+ | `Float _ -> "Float"
+ | `String _ -> "String"
+ | `Sum _ -> "Sum"
+ | `Record _ -> "Record"
+ | `Tuple _ -> "Tuple"
+ | `List _ -> "List"
+ | `Option _ -> "Option"
+ | `Nullable _ -> "Nullable"
+ | `Wrap _ -> "Wrap"
+ | `Name (loc, name, _, _, _) -> "Name " ^ name
+ | `External _ -> "External"
+ | `Tvar _ -> "Tvar"
diff --git a/src/ag_ocaml.ml b/src/ag_ocaml.ml
index 6caab85..41ba52b 100644
--- a/src/ag_ocaml.ml
+++ b/src/ag_ocaml.ml
@@ -412,6 +412,8 @@ let rec ocaml_of_expr_mapping (x : (atd_ocaml_repr, _) mapping) : ocaml_expr =
`Name ("option", [ocaml_of_expr_mapping x])
| `Nullable (loc, x, `Nullable, _) ->
`Name ("option", [ocaml_of_expr_mapping x])
+ | `Wrap _ ->
+ assert false
| `Name (loc, s, l, _, _) ->
`Name (s, List.map ocaml_of_expr_mapping l)
| `Tvar (loc, s) ->
diff --git a/src/ag_oj_emit.ml b/src/ag_oj_emit.ml
index 5bb30ec..b63a322 100644
--- a/src/ag_oj_emit.ml
+++ b/src/ag_oj_emit.ml
@@ -113,16 +113,25 @@ val %s_of_string :%s
)
(flatten defs)
+let is_json_string deref x =
+ (*
+ Calling 'unwrap' allows us to ignore 'wrap' constructors
+ and determine that the JSON representation is a string.
+ This assumes that no '<json>' annotation imposes
+ another representation for the JSON string.
+ *)
+ match Ag_mapping.unwrap deref x with
+ | `String _ -> true
+ | _ -> false (* or maybe we just don't know *)
+
let get_assoc_type deref loc x =
match deref x with
- `Tuple (loc2, [| k; v |], `Tuple, `Tuple) ->
- (match deref k.cel_value with
- `String _ -> ()
- | _ ->
- error loc "Due to <json repr=\"object\"> keys must be strings");
- v.cel_value
- | _ ->
- error loc "Expected due to <json repr=\"object\">: (string * _) list"
+ | `Tuple (loc2, [| k; v |], `Tuple, `Tuple) ->
+ if not (is_json_string deref k.cel_value) then
+ error loc "Due to <json repr=\"object\"> keys must be strings";
+ (k.cel_value, v.cel_value)
+ | _ ->
+ error loc "Expected due to <json repr=\"object\">: (string * _) list"
let nth name i len =
@@ -515,7 +524,7 @@ let rec make_writer p (x : oj_mapping) : Ag_indent.t list =
]
| `Object ->
- let x = get_assoc_type p.deref loc x in
+ let k, v = get_assoc_type p.deref loc x in
let write =
match o with
`List -> "Ag_oj_run.write_assoc_list ("
@@ -523,7 +532,9 @@ let rec make_writer p (x : oj_mapping) : Ag_indent.t list =
in
[
`Line write;
- `Block (make_writer p x);
+ `Block (make_writer p k);
+ `Line ") (";
+ `Block (make_writer p v);
`Line ")";
]
)
@@ -951,7 +962,7 @@ let rec make_reader p type_annot (x : oj_mapping) : Ag_indent.t list =
]
| `Object ->
- let x = get_assoc_type p.deref loc x in
+ let k, v = get_assoc_type p.deref loc x in
let read =
match o with
`List -> "Ag_oj_run.read_assoc_list ("
@@ -959,7 +970,9 @@ let rec make_reader p type_annot (x : oj_mapping) : Ag_indent.t list =
in
[
`Line read;
- `Block (make_reader p None x);
+ `Block (make_reader p None k);
+ `Line ") (";
+ `Block (make_reader p None v);
`Line ")";
]
)
diff --git a/src/ag_oj_run.ml b/src/ag_oj_run.ml
index a10ff6b..d5aced6 100644
--- a/src/ag_oj_run.ml
+++ b/src/ag_oj_run.ml
@@ -57,21 +57,21 @@ let write_array write_item ob a =
array_iter write_item write_comma ob a;
Bi_outbuf.add_char ob ']'
-let write_assoc_list write_item ob l =
+let write_assoc_list write_key write_item ob l =
Bi_outbuf.add_char ob '{';
list_iter (
fun ob (k, v) ->
- Yojson.Safe.write_string ob k;
+ write_key ob k;
Bi_outbuf.add_char ob ':';
write_item ob v
) write_comma ob l;
Bi_outbuf.add_char ob '}'
-let write_assoc_array write_item ob l =
+let write_assoc_array write_key write_item ob l =
Bi_outbuf.add_char ob '{';
array_iter (
fun ob (k, v) ->
- Yojson.Safe.write_string ob k;
+ write_key ob k;
Bi_outbuf.add_char ob ':';
write_item ob v
) write_comma ob l;
@@ -160,13 +160,13 @@ let read_array read_item p lb =
Yojson.Safe.read_space p lb;
Yojson.Safe.read_array read_item p lb
-let read_assoc_list_rev read_item p lb =
+let read_assoc_list_rev read_key read_item p lb =
Yojson.Safe.read_space p lb;
let read acc k p lb = (k, read_item p lb) :: acc in
- Yojson.Safe.read_fields read [] p lb
+ Yojson.Safe.read_abstract_fields read_key read [] p lb
-let read_assoc_list read_item p lb =
- List.rev (read_assoc_list_rev read_item p lb)
+let read_assoc_list read_key read_item p lb =
+ List.rev (read_assoc_list_rev read_key read_item p lb)
let array_of_rev_list l =
match l with
@@ -181,8 +181,8 @@ let array_of_rev_list l =
done;
a
-let read_assoc_array read_item p lb =
- array_of_rev_list (read_assoc_list_rev read_item p lb)
+let read_assoc_array read_key read_item p lb =
+ array_of_rev_list (read_assoc_list_rev read_key read_item p lb)
let read_until_field_value p lb =
Yojson.Safe.read_space p lb;
diff --git a/test/test.atd b/test/test.atd
index 4546f29..29e7fe0 100644
--- a/test/test.atd
+++ b/test/test.atd
@@ -183,6 +183,8 @@ type id = string <ocaml validator="fun path x -> assert false"> wrap
`Id \"\" -> failwith \"empty\"
| _ -> None">
+type json_map = (id * int) list <json repr="object">
+
type natural = int wrap <ocaml module="Test_lib.Natural">
type even_natural = natural wrap <ocaml module="Test_lib.Even_natural">
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ocaml-maint/packages/atdgen.git
More information about the Pkg-ocaml-maint-commits
mailing list