From 931366059e4cfe5bd68cc34140d0aa5f1464c6d4 Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 2 May 2019 21:09:57 +0000 Subject: [PATCH] more jsonized --- src/lib_utils/trace.ml | 10 +++++++ src/lib_utils/x_list.ml | 10 +++++++ src/ligo/ast_simplified/PP.ml | 1 + src/ligo/ast_simplified/types.ml | 1 + src/ligo/ast_typed/PP.ml | 1 + src/ligo/ast_typed/types.ml | 7 +++-- src/ligo/transpiler/transpiler.ml | 1 + src/ligo/typer/typer.ml | 45 ++++++++++++++++++++++++------- 8 files changed, 65 insertions(+), 11 deletions(-) diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml index c2f9c6a33..39b0322f4 100644 --- a/src/lib_utils/trace.ml +++ b/src/lib_utils/trace.ml @@ -175,6 +175,16 @@ let bind_fold_list f init lst = in List.fold_left aux (ok init) lst +let bind_fold_map_list = fun f acc lst -> + let rec aux (acc , prev) f = function + | [] -> ok (acc , prev) + | hd :: tl -> + f acc hd >>? fun (acc' , hd') -> + aux (acc' , hd' :: prev) f tl + in + aux (acc , []) f (List.rev lst) >>? fun (_acc' , lst') -> + ok lst' + let bind_fold_right_list f init lst = let aux x y = x >>? fun x -> diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml index 6439e7f1f..2c28dd98f 100644 --- a/src/lib_utils/x_list.ml +++ b/src/lib_utils/x_list.ml @@ -7,6 +7,16 @@ let map ?(acc = []) f lst = in aux acc f (List.rev lst) +let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list = + fun f acc lst -> + let rec aux (acc , prev) f = function + | [] -> (acc , prev) + | hd :: tl -> + let (acc' , hd') = f acc hd in + aux (acc' , hd' :: prev) f tl + in + snd @@ aux (acc , []) f (List.rev lst) + let fold_right' f init lst = List.fold_left f init (List.rev lst) let filter_map f = diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index 36e339209..32cc895d6 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -50,6 +50,7 @@ and access ppf (a:access) = match a with | Access_tuple n -> fprintf ppf "%d" n | Access_record s -> fprintf ppf "%s" s + | Access_map s -> fprintf ppf "(%a)" annotated_expression s and access_path ppf (p:access_path) = fprintf ppf "%a" (list_sep access (const ".")) p diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index 4df0d9fda..dffa01c67 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -75,6 +75,7 @@ and expression = and access = | Access_tuple of int | Access_record of string + | Access_map of ae and access_path = access list diff --git a/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml index 4363c3490..cbf9fce47 100644 --- a/src/ligo/ast_typed/PP.ml +++ b/src/ligo/ast_typed/PP.ml @@ -87,6 +87,7 @@ and matching : type a . (formatter -> a -> unit) -> _ -> a matching -> unit = fu and pre_access ppf (a:access) = match a with | Access_record n -> fprintf ppf ".%s" n | Access_tuple i -> fprintf ppf ".%d" i + | Access_map n -> fprintf ppf ".%a" annotated_expression n and instruction ppf (i:instruction) = match i with | I_skip -> fprintf ppf "skip" diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index 55e3fb482..f9518586e 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -119,9 +119,12 @@ and instruction = | I_skip | I_patch of named_type_value * access_path * ae -and access = Ast_simplified.access +and access = + | Access_tuple of int + | Access_record of string + | Access_map of ae -and access_path = Ast_simplified.access_path +and access_path = access list and 'a matching = | Match_bool of { diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index c6f6e43e8..ac8ab1cf5 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -137,6 +137,7 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li let%bind (_, path) = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in ok (Map.String.find prop ty_map, path' @ acc) + | Access_map _k -> simple_fail "no patch for map yet" in let%bind (_, path) = bind_fold_list aux (ty, []) s in let%bind v' = translate_annotated_expression env v in diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index f396b1b0e..299a03715 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -159,15 +159,24 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc match access with | I.Access_record s -> let%bind m = O.Combinators.get_t_record ty in - trace_option (simple_error "unbound record access in record_patch") @@ - Map.String.find_opt s m - | Access_tuple i -> + let%bind ty = + trace_option (simple_error "unbound record access in record_patch") @@ + Map.String.find_opt s m in + ok (ty , O.Access_record s) + | I.Access_tuple i -> let%bind t = O.Combinators.get_t_tuple ty in - generic_try (simple_error "unbound tuple access in record_patch") @@ - (fun () -> List.nth t i) + let%bind ty = + generic_try (simple_error "unbound tuple access in record_patch") @@ + (fun () -> List.nth t i) in + ok (ty , O.Access_tuple i) + | I.Access_map ind -> + let%bind (k , v) = O.Combinators.get_t_map ty in + let%bind ind' = type_annotated_expression e ind in + let%bind () = Ast_typed.assert_type_value_eq (get_type_annotation ind' , k) in + ok (v , O.Access_map ind') in - let%bind _assert = bind_fold_list aux ty.type_value (path @ [Access_record s]) in - ok @@ O.I_patch (tv, path @ [Access_record s], ae') + let%bind path' = bind_fold_map_list aux ty.type_value (path @ [Access_record s]) in + ok @@ O.I_patch (tv, path' @ [Access_record s], ae') in let%bind lst' = bind_map_list aux lst in ok (e, lst') @@ -351,6 +360,13 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot @@ (fun () -> SMap.find property r_tv) in return (E_record_accessor (prev , property)) tv ) + | Access_map ae -> ( + let%bind ae' = type_annotated_expression e ae in + let%bind (k , v) = get_t_map prev.type_annotation in + let%bind () = + Ast_typed.assert_type_value_eq (k , get_type_annotation ae') in + return (E_look_up (prev , ae')) v + ) in trace (simple_error "accessing") @@ bind_fold_list aux e' path @@ -643,8 +659,19 @@ and untype_instruction (i:O.instruction) : (I.instruction) result = List.rev_uncons_opt p in let%bind tl_name = match tl with | Access_record n -> ok n - | Access_tuple _ -> simple_fail "last element of patch is tuple" in - ok @@ I_record_patch (s.type_name, hds, [tl_name, e']) + | Access_tuple _ -> simple_fail "last element of patch is tuple" + | Access_map _ -> simple_fail "last element of patch is map" + in + let%bind hds' = bind_map_list untype_access hds in + ok @@ I_record_patch (s.type_name, hds', [tl_name, e']) + +and untype_access (a:O.access) : I.access result = + match a with + | Access_record n -> ok @@ I.Access_record n + | Access_tuple n -> ok @@ I.Access_tuple n + | Access_map n -> + let%bind n' = untype_annotated_expression n in + ok @@ I.Access_map n' and untype_matching : type o i . (o -> i result) -> o O.matching -> (i I.matching) result = fun f m -> let open I in