206 lines
6.6 KiB
OCaml
206 lines
6.6 KiB
OCaml
open Helpers
|
|
|
|
module AST = Ast_typed
|
|
module Append_tree = Tree.Append
|
|
open Mini_c
|
|
open Trace
|
|
|
|
module Errors = struct
|
|
|
|
let corner_case ~loc message =
|
|
let title () = "corner case" in
|
|
let content () = "we don't have a good error message for this case. we are
|
|
striving find ways to better report them and find the use-cases that generate
|
|
them. please report this to the developers." in
|
|
let data = [
|
|
("location" , fun () -> loc) ;
|
|
("message" , fun () -> message) ;
|
|
] in
|
|
error ~data title content
|
|
|
|
let wrong_mini_c_value expected_type actual =
|
|
let title () = "illed typed intermediary value" in
|
|
let content () = "type of intermediary value doesn't match what was expected" in
|
|
let data = [
|
|
("expected_type" , fun () -> expected_type) ;
|
|
("actual" , fun () -> Format.asprintf "%a" Mini_c.PP.value actual ) ;
|
|
] in
|
|
error ~data title content
|
|
|
|
let bad_untranspile bad_type value =
|
|
let title () = "untranspiling bad value" in
|
|
let content () = Format.asprintf "can not untranspile %s" bad_type in
|
|
let data = [
|
|
("bad_type" , fun () -> bad_type) ;
|
|
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
|
|
] in
|
|
error ~data title content
|
|
|
|
let unknown_untranspile unknown_type value =
|
|
let title () = "untranspiling unknown value" in
|
|
let content () = Format.asprintf "can not untranspile %s" unknown_type in
|
|
let data = [
|
|
("unknown_type" , fun () -> unknown_type) ;
|
|
("value" , fun () -> Format.asprintf "%a" Mini_c.PP.value value) ;
|
|
] in
|
|
error ~data title content
|
|
|
|
end
|
|
|
|
open Errors
|
|
|
|
let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression result =
|
|
let open! AST in
|
|
let return e = ok (make_a_e_empty e t) in
|
|
match t.type_value' with
|
|
| T_constant ("unit", []) -> (
|
|
let%bind () =
|
|
trace_strong (wrong_mini_c_value "unit" v) @@
|
|
get_unit v in
|
|
return (E_literal Literal_unit)
|
|
)
|
|
| T_constant ("bool", []) -> (
|
|
let%bind b =
|
|
trace_strong (wrong_mini_c_value "bool" v) @@
|
|
get_bool v in
|
|
return (E_literal (Literal_bool b))
|
|
)
|
|
| T_constant ("int", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "int" v) @@
|
|
get_int v in
|
|
return (E_literal (Literal_int n))
|
|
)
|
|
| T_constant ("nat", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "nat" v) @@
|
|
get_nat v in
|
|
return (E_literal (Literal_nat n))
|
|
)
|
|
| T_constant ("timestamp", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "timestamp" v) @@
|
|
get_timestamp v in
|
|
return (E_literal (Literal_timestamp n))
|
|
)
|
|
| T_constant ("tez", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "tez" v) @@
|
|
get_mutez v in
|
|
return (E_literal (Literal_mutez n))
|
|
)
|
|
| T_constant ("string", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "string" v) @@
|
|
get_string v in
|
|
return (E_literal (Literal_string n))
|
|
)
|
|
| T_constant ("bytes", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "bytes" v) @@
|
|
get_bytes v in
|
|
return (E_literal (Literal_bytes n))
|
|
)
|
|
| T_constant ("address", []) -> (
|
|
let%bind n =
|
|
trace_strong (wrong_mini_c_value "address" v) @@
|
|
get_string v in
|
|
return (E_literal (Literal_address n))
|
|
)
|
|
| T_constant ("option", [o]) -> (
|
|
let%bind opt =
|
|
trace_strong (wrong_mini_c_value "option" v) @@
|
|
get_option v in
|
|
match opt with
|
|
| None -> ok (e_a_empty_none o)
|
|
| Some s ->
|
|
let%bind s' = untranspile s o in
|
|
ok (e_a_empty_some s')
|
|
)
|
|
| T_constant ("map", [k_ty;v_ty]) -> (
|
|
let%bind lst =
|
|
trace_strong (wrong_mini_c_value "map" v) @@
|
|
get_map v in
|
|
let%bind lst' =
|
|
let aux = fun (k, v) ->
|
|
let%bind k' = untranspile k k_ty in
|
|
let%bind v' = untranspile v v_ty in
|
|
ok (k', v') in
|
|
bind_map_list aux lst in
|
|
return (E_map lst')
|
|
)
|
|
| T_constant ("big_map", [k_ty;v_ty]) -> (
|
|
let%bind lst =
|
|
trace_strong (wrong_mini_c_value "big_map" v) @@
|
|
get_big_map v in
|
|
let%bind lst' =
|
|
let aux = fun (k, v) ->
|
|
let%bind k' = untranspile k k_ty in
|
|
let%bind v' = untranspile v v_ty in
|
|
ok (k', v') in
|
|
bind_map_list aux lst in
|
|
return (E_big_map lst')
|
|
)
|
|
| T_constant ("list", [ty]) -> (
|
|
let%bind lst =
|
|
trace_strong (wrong_mini_c_value "list" v) @@
|
|
get_list v in
|
|
let%bind lst' =
|
|
let aux = fun e -> untranspile e ty in
|
|
bind_map_list aux lst in
|
|
return (E_list lst')
|
|
)
|
|
| T_constant ("set", [ty]) -> (
|
|
let%bind lst =
|
|
trace_strong (wrong_mini_c_value "set" v) @@
|
|
get_set v in
|
|
let%bind lst' =
|
|
let aux = fun e -> untranspile e ty in
|
|
bind_map_list aux lst in
|
|
return (E_set lst')
|
|
)
|
|
| T_constant ("contract" , [_ty]) ->
|
|
fail @@ bad_untranspile "contract" v
|
|
| T_constant ("operation" , []) -> (
|
|
let%bind op =
|
|
trace_strong (wrong_mini_c_value "operation" v) @@
|
|
get_operation v in
|
|
return (E_literal (Literal_operation op))
|
|
)
|
|
| T_constant (name , _lst) ->
|
|
fail @@ unknown_untranspile name v
|
|
| T_sum m ->
|
|
let lst = kv_list_of_map m in
|
|
let%bind node = match Append_tree.of_list lst with
|
|
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty sum type"
|
|
| Full t -> ok t
|
|
in
|
|
let%bind (name, v, tv) =
|
|
trace_strong (corner_case ~loc:__LOC__ "sum extract constructor") @@
|
|
extract_constructor v node in
|
|
let%bind sub = untranspile v tv in
|
|
return (E_constructor (name, sub))
|
|
| T_tuple lst ->
|
|
let%bind node = match Append_tree.of_list lst with
|
|
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty tuple"
|
|
| Full t -> ok t in
|
|
let%bind tpl =
|
|
trace_strong (corner_case ~loc:__LOC__ "tuple extract") @@
|
|
extract_tuple v node in
|
|
let%bind tpl' = bind_list
|
|
@@ List.map (fun (x, y) -> untranspile x y) tpl in
|
|
return (E_tuple tpl')
|
|
| T_record m ->
|
|
let lst = kv_list_of_map m in
|
|
let%bind node = match Append_tree.of_list lst with
|
|
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
|
|
| Full t -> ok t in
|
|
let%bind lst =
|
|
trace_strong (corner_case ~loc:__LOC__ "record extract") @@
|
|
extract_record v node in
|
|
let%bind lst = bind_list
|
|
@@ List.map (fun (x, (y, z)) -> let%bind yz = untranspile y z in ok (x, yz)) lst in
|
|
let m' = map_of_kv_list lst in
|
|
return (E_record m')
|
|
| T_function _ -> fail @@ bad_untranspile "function" v
|