balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

remove 'Access_Map'

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2019-11-12 14:28:58 +00:00
parent d0c0fcff14
commit f91de985d0
11 changed files with 16 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
src/passes/3-self_ast_simplified/helpers.ml
View File

@ -8,26 +8,25 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
match e.expression with
| E_literal _ | E_variable _ | E_skip -> ok init'
| E_list lst | E_set lst | E_tuple lst | E_constant (_ , lst) -> (
let%bind res' = bind_fold_list self init' lst in
ok res'
let%bind res = bind_fold_list self init' lst in
ok res
)
| E_map lst | E_big_map lst -> (
let%bind res' = bind_fold_list (bind_fold_pair self) init' lst in
ok res'
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
ok res
)
| E_look_up ab | E_sequence ab | E_loop ab | E_application ab -> (
let%bind res' = bind_fold_pair self init' ab in
ok res'
let%bind res = bind_fold_pair self init' ab in
ok res
)
| E_lambda { binder = _ ; input_type = _ ; output_type = _ ; result = e }
| E_annotation (e , _) | E_constructor (_ , e) -> (
let%bind res' = self init' e in
ok res'
let%bind res = self init' e in
ok res
)
| E_assign (_ , path , e) | E_accessor (e , path) -> (
let%bind res' = fold_path f init' path in
let%bind res' = self res' e in
ok res'
| E_assign (_ , _path , e) | E_accessor (e , _path) -> (
let%bind res = self init' e in
ok res
)
| E_matching (e , cases) -> (
let%bind res = self init' e in
@ -36,8 +35,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
)
| E_record m -> (
let aux init'' _ expr =
let%bind res' = fold_expression self init'' expr in
ok res'
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_smap aux (ok init') m in
ok res
@ -48,16 +47,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
and fold_path : 'a folder -> 'a -> access_path -> 'a result = fun f init p -> bind_fold_list (fold_access f) init p
and fold_access : 'a folder -> 'a -> access -> 'a result = fun f init a ->
match a with
| Access_map e -> (
let%bind e' = fold_expression f init e in
ok e'
)
| _ -> ok init
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
@ -127,8 +116,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
)
| E_assign (name , path , e) -> (
let%bind e' = self e in
let%bind path' = map_path f path in
return @@ E_assign (name , path' , e')
return @@ E_assign (name , path , e')
)
| E_matching (e , cases) -> (
let%bind e' = self e in
@ -137,8 +125,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
)
| E_accessor (e , path) -> (
let%bind e' = self e in
let%bind path' = map_path f path in
return @@ E_accessor (e' , path')
return @@ E_accessor (e' , path)
)
| E_record m -> (
let%bind m' = bind_map_smap self m in
@ -171,15 +158,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
)
| E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_path : mapper -> access_path -> access_path result = fun f p -> bind_map_list (map_access f) p
and map_access : mapper -> access -> access result = fun f a ->
match a with
| Access_map e -> (
let%bind e' = map_expression f e in
ok @@ Access_map e'
)
| a -> ok a
and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
match m with

15
src/passes/4-typer-new/solver.ml
View File

@ -150,7 +150,6 @@ module Wrap = struct
(* let t_literal_t = t *)
let t_literal_bool = bool
let t_literal_string = string
let t_access_map = forall2 "k" "v" @@ fun k v -> map k v --> k --> v
let t_application = forall2 "a" "b" @@ fun a b -> (a --> b) --> a --> b
let t_look_up = forall2 "ind" "v" @@ fun ind v -> map ind v --> ind --> option v
let t_sequence = forall "b" @@ fun b -> unit --> b --> b
@ -166,20 +165,6 @@ module Wrap = struct
let access_int ~base ~index = access_label ~base ~label:(L_int index)
let access_string ~base ~property = access_label ~base ~label:(L_string property)
let access_map : base:T.type_value -> key:T.type_value -> (constraints * T.type_name) =
let mk_map_type key_type element_type =
O.P_constant O.(C_map , [P_variable element_type; P_variable key_type]) in
fun ~base ~key ->
let key_type = Core.fresh_type_variable () in
let element_type = Core.fresh_type_variable () in
let base' = type_expression_to_type_value base in
let key' = type_expression_to_type_value key in
let base_expected = mk_map_type key_type element_type in
let expr_type = Core.fresh_type_variable () in
O.[C_equation (base' , base_expected);
C_equation (key' , P_variable key_type);
C_equation (P_variable expr_type , P_variable element_type)] , Type_name expr_type
let constructor
: T.type_value -> T.type_value -> T.type_value -> (constraints * T.type_name)
= fun t_arg c_arg sum ->

19
src/passes/4-typer-new/typer.ml
View File

@ -191,15 +191,6 @@ module Errors = struct
] in
error ~data title message ()
let not_supported_yet (message : string) (ae : I.expression) () =
let title = (thunk "not supported yet") in
let message () = message in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
let title = (thunk "not supported yet") in
let message () = message in
@ -491,14 +482,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
let wrapped = Wrap.access_string ~base:base'.type_annotation ~property in
return_wrapped (E_record_accessor (base' , property)) state' wrapped
)
| E_accessor (base , [Access_map key_ae]) -> (
let%bind (base' , state') = type_expression e state base in
let%bind (key_ae' , state'') = type_expression e state' key_ae in
let xyz = get_type_annotation key_ae' in
let wrapped = Wrap.access_map ~base:base'.type_annotation ~key:xyz in
return_wrapped (E_look_up (base' , key_ae')) state'' wrapped
)
| E_accessor (_base , []) | E_accessor (_base , _ :: _ :: _) -> (
failwith
"The simplifier should produce E_accessor with only a single path element, not a list of path elements."
@ -791,8 +774,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_value -> I.e
Map.String.find_opt property m in
ok (tv' , prec_path @ [O.Access_record property])
)
| Access_map _ ->
fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae
in
bind_fold_list aux (typed_name.type_value , []) path in
let%bind (expr' , state') = type_expression e state expr in

9
src/passes/4-typer-new/typer.ml.old
View File

@ -449,13 +449,6 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -
@@ (fun () -> SMap.find property r_tv) in
return (E_record_accessor (prev , property)) tv
)
| Access_map ae' -> (
let%bind ae'' = type_expression e ae' in
let%bind (k , v) = get_t_map prev.type_annotation in
let%bind () =
Ast_typed.assert_type_expression_eq (k , get_type_annotation ae'') in
return (E_look_up (prev , ae'')) v
)
in
trace (simple_info "accessing") @@
bind_fold_list aux e' path
@ -725,8 +718,6 @@ and type_expression : environment -> ?tv_opt:O.type_expression -> I.expression -
Map.String.find_opt property m in
ok (tv' , prec_path @ [O.Access_record property])
)
| Access_map _ ->
fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae
in
bind_fold_list aux (typed_name.type_expression , []) path in
let%bind expr' = type_expression e expr in

18
src/passes/4-typer-old/typer.ml
View File

@ -191,15 +191,6 @@ module Errors = struct
] in
error ~data title message ()
let not_supported_yet (message : string) (ae : I.expression) () =
let title = (thunk "not suported yet") in
let message () = message in
let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in
error ~data title message ()
let not_supported_yet_untranspile (message : string) (ae : O.expression) () =
let title = (thunk "not suported yet") in
let message () = message in
@ -450,13 +441,6 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
@@ (fun () -> SMap.find property r_tv) in
return (E_record_accessor (prev , property)) tv
)
| Access_map ae' -> (
let%bind ae'' = type_expression' e ae' in
let%bind (k , v) = bind_map_or (get_t_map , get_t_big_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_info "accessing") @@
bind_fold_list aux e' path
@ -758,8 +742,6 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O.
Map.String.find_opt property m in
ok (tv' , prec_path @ [O.Access_record property])
)
| Access_map _ ->
fail @@ not_supported_yet "assign expressions with maps are not supported yet" ae
in
bind_fold_list aux (typed_name.type_value , []) path in
let%bind expr' = type_expression' e ~tv_opt:assign_tv expr in

1
src/passes/6-transpiler/transpiler.ml
View File

@ -510,7 +510,6 @@ and transpile_annotated_expression (ae:AST.annotated_expression) : expression re
(Map.String.find_opt prop ty_map) in
ok (prop_in_ty_map, acc @ path')
)
| Access_map _k -> fail (corner_case ~loc:__LOC__ "no patch for map yet")
in
let%bind (_, path) = bind_fold_right_list aux (ty, []) path in
let%bind expr' = transpile_annotated_expression expr in

1
src/stages/ast_simplified/PP.ml
View File

@ -82,7 +82,6 @@ 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)" expression s
and access_path ppf (p:access_path) =
fprintf ppf "%a" (list_sep access (const ".")) p

3
src/stages/ast_simplified/combinators.ml
View File

@ -148,8 +148,7 @@ let assert_e_accessor = fun t ->
let get_access_record : access -> string result = fun a ->
match a with
| Access_tuple _
| Access_map _ -> simple_fail "not an access record"
| Access_tuple _ -> simple_fail "not an access record"
| Access_record s -> ok s
let get_e_pair = fun t ->

1
src/stages/ast_simplified/types.ml
View File

@ -81,7 +81,6 @@ and expression = {
and access =
| Access_tuple of int
| Access_record of string
| Access_map of expr
and access_path = access list

1
src/stages/ast_typed/PP.ml
View File

@ -98,7 +98,6 @@ 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
let declaration ppf (d:declaration) =
match d with

1
src/stages/ast_typed/types.ml
View File

@ -131,7 +131,6 @@ and literal =
and access =
| Access_tuple of int
| Access_record of string
| Access_map of ae
and access_path = access list