From eaf749cbc51840bfe68aaa0b1a324287a730d142 Mon Sep 17 00:00:00 2001 From: Galfour Date: Fri, 19 Apr 2019 07:59:16 +0000 Subject: [PATCH] refactor: mini_c expression built and access through combinators --- src/ligo/mini_c/PP.ml | 10 +- src/ligo/mini_c/combinators.ml | 76 +++++-------- src/ligo/mini_c/combinators_smart.ml | 51 +++++++++ src/ligo/mini_c/compiler.ml | 56 ++++----- src/ligo/mini_c/compiler_environment.ml | 26 ++--- src/ligo/mini_c/dune | 2 +- src/ligo/mini_c/mini_c.ml | 5 +- src/ligo/mini_c/run.ml | 4 +- src/ligo/mini_c/types.ml | 7 +- src/ligo/transpiler.ml | 145 +++++++++++++----------- 10 files changed, 218 insertions(+), 164 deletions(-) create mode 100644 src/ligo/mini_c/combinators_smart.ml diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index b038b1c5c..fdcf39524 100644 --- a/src/ligo/mini_c/PP.ml +++ b/src/ligo/mini_c/PP.ml @@ -73,11 +73,13 @@ and expression' ppf (e:expression') = match e with | E_make_none _ -> fprintf ppf "none" | E_Cond (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b -and expression ppf (e' , _ , _) = expression' ppf e' - -and expression_with_type = fun ppf (e' , t , _) -> - fprintf ppf "%a : %a" expression' e' type_ t +and expression : _ -> expression -> _ = fun ppf e -> + expression' ppf (Combinators.Expression.get_content e) +and expression_with_type : _ -> expression -> _ = fun ppf e -> + fprintf ppf "%a : %a" + expression' (Combinators.Expression.get_content e) + type_ (Combinators.Expression.get_type e) and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon_function_content) = fprintf ppf "fun[%s] (%s:%a) : %a %a return %a" diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index bb3454f01..53ceaf8de 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/src/ligo/mini_c/combinators.ml @@ -1,6 +1,30 @@ open Trace open Types +module Expression = struct + type t' = expression' + type t = expression + + let get_content : t -> t' = fun e -> e.content + let get_type : t -> type_value = fun e -> e.type_value + let get_environment : t -> environment = fun e -> e.environment + let is_toplevel : t -> bool = fun e -> e.is_toplevel + + let make = fun ?(itl = false) e' t env -> { + content = e' ; + type_value = t ; + environment = env ; + is_toplevel = itl ; + } + + let make_tpl = fun ?(itl = false) (e' , t , env) -> { + content = e' ; + type_value = t ; + environment = env ; + is_toplevel = itl ; + } +end + let get_bool (v:value) = match v with | D_bool b -> ok b | _ -> simple_fail "not a bool" @@ -93,64 +117,16 @@ let quote binder input output body result : anon_function = let basic_quote i o b : anon_function result = let%bind (_, e) = get_last_statement b in - let r : expression = (E_variable "output", o, e.post_environment) in + let r : expression = Expression.make_tpl (E_variable "output", o, e.post_environment) in ok @@ quote "input" i o b r let basic_int_quote b : anon_function result = basic_quote t_int t_int b -let basic_int_quote_env : environment = - let e = Compiler_environment.empty in - Compiler_environment.add ("input", t_int) e - -let e_int expr env : expression = (expr, t_int, env) +let e_int expr env : expression = Expression.make_tpl (expr, t_int, env) let e_var_int name env : expression = e_int (E_variable name) env let d_unit : value = D_unit let environment_wrap pre_environment post_environment = { pre_environment ; post_environment } let id_environment_wrap e = environment_wrap e e - -let statement s' e : statement = - match s' with - | S_environment_extend -> s', environment_wrap e (Compiler_environment.extend e) - | S_environment_restrict -> s', environment_wrap e (Compiler_environment.restrict e) - | S_environment_add (name, tv) -> s', environment_wrap e (Compiler_environment.add (name, tv) e) - | S_cond _ -> s', id_environment_wrap e - | S_if_none _ -> s', id_environment_wrap e - | S_while _ -> s', id_environment_wrap e - | S_patch _ -> s', id_environment_wrap e - | S_declaration (name, (_, t, _)) -> s', environment_wrap e (Compiler_environment.add (name, t) e) - | S_assignment (name, (_, t, _)) -> s', environment_wrap e (Compiler_environment.add (name, t) e) - -let block (statements:statement list) : block result = - match statements with - | [] -> simple_fail "no statements in block" - | lst -> - let first = List.hd lst in - let last = List.(nth lst (length lst - 1)) in - ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment) - -let append_statement' : block -> statement' -> block = fun b s' -> - let b_wrap = snd b in - let s = statement s' b_wrap.post_environment in - let s_wrap = snd s in - let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in - let b_content = fst b in - (b_content @ [s], b_wrap') - -let prepend_statement : statement -> block -> block = fun s b -> - let s_wrap = snd s in - let b_wrap = snd b in - let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in - let b_content = fst b in - (s :: b_content, b_wrap') - -let statements (lst:(environment -> statement) list) e : statement list = - let rec aux lst e = match lst with - | [] -> [] - | hd :: tl -> - let s = hd e in - s :: aux tl (snd s).post_environment - in - aux lst e diff --git a/src/ligo/mini_c/combinators_smart.ml b/src/ligo/mini_c/combinators_smart.ml new file mode 100644 index 000000000..e5b0710aa --- /dev/null +++ b/src/ligo/mini_c/combinators_smart.ml @@ -0,0 +1,51 @@ +open Trace +open Types +open Combinators + +let basic_int_quote_env : environment = + let e = Compiler_environment.empty in + Compiler_environment.add ("input", t_int) e + +let statement s' env : statement = + match s' with + | S_environment_extend -> s', environment_wrap env (Compiler_environment.extend env) + | S_environment_restrict -> s', environment_wrap env (Compiler_environment.restrict env) + | S_environment_add (name, tv) -> s' , environment_wrap env (Compiler_environment.add (name , tv) env) + | S_cond _ -> s' , id_environment_wrap env + | S_if_none _ -> s' , id_environment_wrap env + | S_while _ -> s' , id_environment_wrap env + | S_patch _ -> s' , id_environment_wrap env + | S_declaration (name , e) -> s', environment_wrap env (Compiler_environment.add (name , (Expression.get_type e)) env) + | S_assignment (name , e) -> s', environment_wrap env (Compiler_environment.add (name , (Expression.get_type e)) env) + +let block (statements:statement list) : block result = + match statements with + | [] -> simple_fail "no statements in block" + | lst -> + let first = List.hd lst in + let last = List.(nth lst (length lst - 1)) in + ok (lst, environment_wrap (snd first).pre_environment (snd last).post_environment) + +let append_statement' : block -> statement' -> block = fun b s' -> + let b_wrap = snd b in + let s = statement s' b_wrap.post_environment in + let s_wrap = snd s in + let b_wrap' = { b_wrap with post_environment = s_wrap.post_environment } in + let b_content = fst b in + (b_content @ [s], b_wrap') + +let prepend_statement : statement -> block -> block = fun s b -> + let s_wrap = snd s in + let b_wrap = snd b in + let b_wrap' = { b_wrap with pre_environment = s_wrap.pre_environment } in + let b_content = fst b in + (s :: b_content, b_wrap') + +let statements (lst:(environment -> statement) list) e : statement list = + let rec aux lst e = match lst with + | [] -> [] + | hd :: tl -> + let s = hd e in + s :: aux tl (snd s).post_environment + in + aux lst e diff --git a/src/ligo/mini_c/compiler.ml b/src/ligo/mini_c/compiler.ml index 6955e3f07..5fb3969bb 100644 --- a/src/ligo/mini_c/compiler.ml +++ b/src/ligo/mini_c/compiler.ml @@ -55,8 +55,8 @@ let rec get_predicate : string -> expression list -> predicate result = fun s ls (* | "CONS" -> ok @@ simple_binary @@ seq [prim I_SWAP ; prim I_CONS] *) | "MAP_REMOVE" -> let%bind v = match lst with - | [ _ ; (_, m, _) ] -> - let%bind (_, v) = Combinators.get_t_map m in + | [ _ ; expr ] -> + let%bind (_, v) = Combinators.(get_t_map (Expression.get_type expr)) in ok v | _ -> simple_fail "mini_c . MAP_REMOVE" in let%bind v_ty = Compiler_type.type_ v in @@ -113,7 +113,8 @@ and translate_function ({capture;content}:anon_function) : michelson result = ok @@ d_pair capture_m body | _ -> simple_fail "compiling closure without capture" -and translate_expression ((expr', ty, env) as expr:expression) : michelson result = +and translate_expression (expr:expression) : michelson result = + let (expr' , ty , env) = Combinators.Expression.(get_content expr , get_type expr , get_environment expr) in let error_message () = Format.asprintf "%a" PP.expression expr in let return code = @@ -157,8 +158,8 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul prim ~children:[t;v] I_PUSH ; prim I_PAIR ; ] - | E_application((_, f_ty, _) as f, arg) -> ( - match f_ty with + | E_application(f, arg) -> ( + match Combinators.Expression.get_type f with | T_function _ -> ( trace (simple_error "Compiling quote application") @@ let%bind f = translate_expression f in @@ -259,22 +260,22 @@ and translate_expression ((expr', ty, env) as expr:expression) : michelson resul i_pair ; ] in return code - | Deep_capture small_env -> - (* Capture the variable bounds, assemble them. On call, append the input. *) - let senv_type = Compiler_environment.Small.to_mini_c_type small_env in - let%bind body = translate_closure_body anon senv_type in - let%bind capture = Environment.Small.to_mini_c_capture env small_env in - let%bind capture = translate_expression capture in - let%bind input_type = Compiler_type.type_ anon.input in - let%bind output_type = Compiler_type.type_ anon.output in - let code = seq [ - capture ; - i_unpair ; - i_lambda input_type output_type body ; - i_piar ; - i_pair ; - ] in - return code + | Deep_capture _small_env -> simple_fail "no deep capture expression yet" + (* (\* Capture the variable bounds, assemble them. On call, append the input. *\) + * let senv_type = Compiler_environment.Small.to_mini_c_type small_env in + * let%bind body = translate_closure_body anon senv_type in + * let%bind capture = Environment.Small.to_mini_c_capture env small_env in + * let%bind capture = translate_expression capture in + * let%bind input_type = Compiler_type.type_ anon.input in + * let%bind output_type = Compiler_type.type_ anon.output in + * let code = seq [ + * capture ; + * i_unpair ; + * i_lambda input_type output_type body ; + * i_piar ; + * i_pair ; + * ] in + * return code *) | Shallow_capture env -> (* Capture the whole environment. *) let env_type = Compiler_environment.to_mini_c_type env in @@ -330,7 +331,8 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = simple_fail "not ready yet" (* | S_environment_add (name, tv) -> * Environment.to_michelson_add (name, tv) w_env.pre_environment *) - | S_declaration (s, ((_, tv, _) as expr)) -> + | S_declaration (s, expr) -> + let tv = Combinators.Expression.get_type expr in let%bind expr = translate_expression expr in let%bind add = Environment.to_michelson_add (s, tv) w_env.pre_environment in ok (seq [ @@ -382,7 +384,7 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = seq [add ; some'] ; ] I_IF_NONE ]) - | S_while ((_, _, _) as expr, block) -> + | S_while (expr, block) -> let%bind expr = translate_expression expr in let%bind block' = translate_regular_block block in let%bind restrict_block = @@ -540,12 +542,12 @@ type compiled_program = { } let translate_program (p:program) (entry:string) : compiled_program result = - let is_main ((s, _):toplevel_statement) = - match s with - | name , (E_function f, T_function (_, _), _) + let is_main (((name , expr), _):toplevel_statement) = + match Combinators.Expression.(get_content expr , get_type expr)with + | (E_function f , T_function _) when f.capture_type = No_capture && name = entry -> Some f - | name , (E_literal (D_function {content ; capture = None}), T_function (_, _), _) + | (E_literal (D_function {content ; capture = None}) , T_function _) when name = entry -> Some content | _ -> None diff --git a/src/ligo/mini_c/compiler_environment.ml b/src/ligo/mini_c/compiler_environment.ml index 54f541f4d..d7ea26e4d 100644 --- a/src/ligo/mini_c/compiler_environment.ml +++ b/src/ligo/mini_c/compiler_environment.ml @@ -117,16 +117,16 @@ module Small = struct | Empty -> ok (dip i_drop) | Full x -> to_michelson_append' x - let rec to_mini_c_capture' env : _ -> expression result = function - | Leaf (n, tv) -> ok (E_variable n, tv, env) - | Node {a;b} -> - let%bind ((_, ty_a, _) as a) = to_mini_c_capture' env a in - let%bind ((_, ty_b, _) as b) = to_mini_c_capture' env b in - ok (E_constant ("PAIR", [a;b]), (T_pair(ty_a, ty_b) : type_value), env) - - let to_mini_c_capture env = function - | Empty -> simple_fail "to_mini_c_capture" - | Full x -> to_mini_c_capture' env x + (* let rec to_mini_c_capture' env : _ -> expression result = function + * | Leaf (n, tv) -> ok (E_variable n, tv, env) + * | Node {a;b} -> + * let%bind ((_, ty_a, _) as a) = to_mini_c_capture' env a in + * let%bind ((_, ty_b, _) as b) = to_mini_c_capture' env b in + * ok (E_constant ("PAIR", [a;b]), (T_pair(ty_a, ty_b) : type_value), env) + * + * let to_mini_c_capture env = function + * | Empty -> simple_fail "to_mini_c_capture" + * | Full x -> to_mini_c_capture' env x *) let rec to_mini_c_type' : _ -> type_value = function | Leaf (_, t) -> t @@ -183,9 +183,9 @@ let rec to_mini_c_type = function | [hd] -> Small.to_mini_c_type hd | Append_tree.Empty :: tl -> to_mini_c_type tl | hd :: tl -> T_pair(Small.to_mini_c_type hd, to_mini_c_type tl) -let to_mini_c_capture = function - | [a] -> Small.to_mini_c_capture a - | _ -> raise (Failure "Schema.Big.to_mini_c_capture") +(* let to_mini_c_capture = function + * | [a] -> Small.to_mini_c_capture a + * | _ -> raise (Failure "Schema.Big.to_mini_c_capture") *) type path = [`Left | `Right] list let pp_path : _ -> path -> unit = diff --git a/src/ligo/mini_c/dune b/src/ligo/mini_c/dune index c2e24e879..7321242e5 100644 --- a/src/ligo/mini_c/dune +++ b/src/ligo/mini_c/dune @@ -8,5 +8,5 @@ (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-9-44-40-42-48@39@33 -open Tezos_utils )) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Tezos_utils )) ) diff --git a/src/ligo/mini_c/mini_c.ml b/src/ligo/mini_c/mini_c.ml index 110ed06ae..aa7f86780 100644 --- a/src/ligo/mini_c/mini_c.ml +++ b/src/ligo/mini_c/mini_c.ml @@ -1,7 +1,10 @@ include Types module PP = PP -module Combinators = Combinators +module Combinators = struct + include Combinators + include Combinators_smart +end module Environment = Compiler_environment module Compiler_type = Compiler_type module Compiler = Compiler diff --git a/src/ligo/mini_c/run.ml b/src/ligo/mini_c/run.ml index e9e9a54d5..5d77d1fb3 100644 --- a/src/ligo/mini_c/run.ml +++ b/src/ligo/mini_c/run.ml @@ -51,8 +51,8 @@ let run (program:program) (input:value) : value result = let%bind (result : value) = Uncompiler.translate_value ex_ty_value in ok result -let expression_to_value ((e', _, _) as e:expression) : value result = - match e' with +let expression_to_value (e:expression) : value result = + match (Combinators.Expression.get_content e) with | E_literal v -> ok v | _ -> fail @@ error (thunk "not a value") diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index 4e8baeaa3..5be6bb02a 100644 --- a/src/ligo/mini_c/types.ml +++ b/src/ligo/mini_c/types.ml @@ -65,7 +65,12 @@ and expression' = | E_make_none of type_value | E_Cond of expression * expression * expression -and expression = expression' * type_value * environment (* Environment in which the expressions are evaluated *) +and expression = { + content : expression' ; + type_value : type_value ; + environment : environment ; (* Environment in which the expressions are evaluated *) + is_toplevel : bool ; +} and assignment = var_name * expression diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index b10c9375f..ee5f9356d 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -118,8 +118,8 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li let return ?(env' = env) x : statement list result = ok ([x, environment_wrap env env']) in match i with | I_declaration {name;annotated_expression} -> - let%bind (_, t, _) as expression = translate_annotated_expression env annotated_expression in - let env' = Environment.add (name, t) env in + let%bind expression = translate_annotated_expression env annotated_expression in + let env' = Environment.add (name, (Combinators.Expression.get_type expression)) env in return ~env' (S_declaration (name, expression)) | I_assignment {name;annotated_expression} -> let%bind expression = translate_annotated_expression env annotated_expression in @@ -179,62 +179,67 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li | I_skip -> ok [] | I_fail _ -> simple_fail "todo : fail" +and translate_literal : AST.literal -> value = fun l -> match l with + | Literal_bool b -> D_bool b + | Literal_int n -> D_int n + | Literal_nat n -> D_nat n + | Literal_bytes s -> D_bytes s + | Literal_string s -> D_string s + | Literal_unit -> D_unit + and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result = let%bind tv = translate_type ae.type_annotation in - let return (expr, tv) = ok (expr, tv, env) in + let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv, env) in let f = translate_annotated_expression env in match ae.expression with - | E_literal (Literal_bool b) -> ok (E_literal (D_bool b), tv, env) - | E_literal (Literal_int n) -> ok (E_literal (D_int n), tv, env) - | E_literal (Literal_nat n) -> ok (E_literal (D_nat n), tv, env) - | E_literal (Literal_bytes s) -> ok (E_literal (D_bytes s), tv, env) - | E_literal (Literal_string s) -> ok (E_literal (D_string s), tv, env) - | E_literal Literal_unit -> ok (E_literal D_unit, tv, env) + | E_literal l -> return @@ E_literal (translate_literal l) | E_variable name -> let%bind tv = trace_option (simple_error "transpiler: variable not in env") @@ Environment.get_opt env name in - ok (E_variable name, tv, env) + return ~tv @@ E_variable name | E_application (a, b) -> let%bind a = translate_annotated_expression env a in let%bind b = translate_annotated_expression env b in - ok (E_application (a, b), tv, env) + return @@ E_application (a, b) | E_constructor (m, param) -> - let%bind (param'_expr, param'_tv, _) = translate_annotated_expression env ae in + let%bind param' = translate_annotated_expression env ae in + let (param'_expr , param'_tv) = Combinators.Expression.(get_content param' , get_type param') in let%bind map_tv = get_t_sum ae.type_annotation in let node_tv = Append_tree.of_list @@ kv_list_of_map map_tv in - let%bind ae' = - let leaf (k, tv) : (expression' option * type_value) result = - if k = m then ( - let%bind _ = - trace (simple_error "constructor parameter doesn't have expected type (shouldn't happen here)") - @@ AST.assert_type_value_eq (tv, param.type_annotation) in - ok (Some (param'_expr), param'_tv) - ) else ( - let%bind tv = translate_type tv in - ok (None, tv) - ) in - let node a b : (expression' option * type_value) result = - let%bind a = a in - let%bind b = b in - match (a, b) with - | (None, a), (None, b) -> ok (None, T_or (a, b)) - | (Some _, _), (Some _, _) -> simple_fail "several identical constructors in the same variant (shouldn't happen here)" - | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [v, a, env])), T_or (a, b)) - | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [v, b, env])), T_or (a, b)) - in - let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in - let%bind ae = - trace_option (simple_error "constructor doesn't exist in claimed type (shouldn't happen here)") - ae_opt in - ok (ae, tv, env) in - ok ae' + let leaf (k, tv) : (expression' option * type_value) result = + if k = m then ( + let%bind _ = + trace (simple_error "constructor parameter doesn't have expected type (shouldn't happen here)") + @@ AST.assert_type_value_eq (tv, param.type_annotation) in + ok (Some (param'_expr), param'_tv) + ) else ( + let%bind tv = translate_type tv in + ok (None, tv) + ) in + let node a b : (expression' option * type_value) result = + let%bind a = a in + let%bind b = b in + match (a, b) with + | (None, a), (None, b) -> ok (None, T_or (a, b)) + | (Some _, _), (Some _, _) -> simple_fail "several identical constructors in the same variant (shouldn't happen here)" + | (Some v, a), (None, b) -> ok (Some (E_constant ("LEFT", [Combinators.Expression.make_tpl (v, a, env)])), T_or (a, b)) + | (None, a), (Some v, b) -> ok (Some (E_constant ("RIGHT", [Combinators.Expression.make_tpl (v, b, env)])), T_or (a, b)) + in + let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in + let%bind ae = + trace_option (simple_error "constructor doesn't exist in claimed type (shouldn't happen here)") + ae_opt in + return ~tv ae | E_tuple lst -> let node = Append_tree.of_list lst in let aux (a:expression result) (b:expression result) : expression result = - let%bind (_, a_ty, _) as a = a in - let%bind (_, b_ty, _) as b = b in - ok (E_constant ("PAIR", [a; b]), T_pair(a_ty, b_ty), env) + let%bind a = a in + let%bind b = b in + let a_ty = Combinators.Expression.get_type a in + let b_ty = Combinators.Expression.get_type b in + let tv = T_pair (a_ty , b_ty) in + return ~tv @@ E_constant ("PAIR", [a; b]) in Append_tree.fold_ne (translate_annotated_expression env) aux node | E_tuple_accessor (tpl, ind) -> @@ -246,22 +251,31 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express let c = match lr with | `Left -> "CAR" | `Right -> "CDR" in - E_constant (c, [pred]), ty, env in + Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty , env) in let%bind tpl' = translate_annotated_expression env tpl in let expr = List.fold_left aux tpl' path in ok expr | E_record m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : expression result = - let%bind (_, a_ty, _) as a = a in - let%bind (_, b_ty, _) as b = b in - ok (E_constant ("PAIR", [a; b]), T_pair(a_ty, b_ty), env) + let%bind a = a in + let%bind b = b in + let a_ty = Combinators.Expression.get_type a in + let b_ty = Combinators.Expression.get_type b in + let tv = T_pair (a_ty , b_ty) in + return ~tv @@ E_constant ("PAIR", [a; b]) in Append_tree.fold_ne (translate_annotated_expression env) aux node | E_record_accessor (record, property) -> let%bind translation = translate_annotated_expression env record in let%bind record_type_map = - trace (simple_error (Format.asprintf "Accessing field of %a, that has type %a, which isn't a record" AST.PP.annotated_expression record AST.PP.type_value record.type_annotation)) @@ + let error = + let title () = + Format.asprintf "Accessing field of %a, that has type %a, which isn't a record" + AST.PP.annotated_expression record AST.PP.type_value record.type_annotation in + let content () = "" in + error title content in + trace error @@ get_t_record record.type_annotation in let node_tv = Append_tree.of_list @@ kv_list_of_map record_type_map in let leaf (key, _) : expression result = @@ -272,13 +286,13 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express ) in let node (a:expression result) b : expression result = match%bind bind_lr (a, b) with - | `Left ((_, t, env) as ex) -> ( - let%bind (a, _) = get_t_pair t in - ok (E_constant ("CAR", [ex]), a, env) + | `Left expr -> ( + let%bind (tv, _) = get_t_pair @@ Combinators.Expression.get_type expr in + return ~tv @@ E_constant ("CAR", [expr]) ) - | `Right ((_, t, env) as ex) -> ( - let%bind (_, b) = get_t_pair t in - ok (E_constant ("CDR", [ex]), b, env) + | `Right expr -> ( + let%bind (_, tv) = get_t_pair @@ Combinators.Expression.get_type expr in + return ~tv @@ E_constant ("CDR", [expr]) ) in let%bind expr = trace_strong (simple_error "bad key in record (shouldn't happen here)") @@ @@ -289,16 +303,16 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express match name, lst with | "NONE", [] -> let%bind o = Mini_c.Combinators.get_t_option tv in - ok (E_make_none o, tv, env) - | _ -> ok (E_constant (name, lst'), tv, env) + return @@ E_make_none o + | _ -> return @@ E_constant (name, lst') ) | E_lambda l -> translate_lambda env l | E_list lst -> let%bind t = Mini_c.Combinators.get_t_list tv in let%bind lst' = bind_map_list (translate_annotated_expression env) lst in let aux : expression -> expression -> expression result = fun prev cur -> - return (E_constant ("CONS", [cur ; prev]), tv) in - let%bind (init : expression) = return (E_empty_list t, tv) in + return @@ E_constant ("CONS", [cur ; prev]) in + let%bind (init : expression) = return @@ E_empty_list t in bind_fold_list aux init lst' | E_map m -> let%bind (src, dst) = Mini_c.Combinators.get_t_map tv in @@ -307,19 +321,19 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express let%bind (k', v') = let v' = e_a_some v in bind_map_pair (translate_annotated_expression env) (k, v') in - return (E_constant ("UPDATE", [k' ; v' ; prev']), tv) + return @@ E_constant ("UPDATE", [k' ; v' ; prev']) in - let init = return (E_empty_map (src, dst), tv) in + let init = return @@ E_empty_map (src, dst) in List.fold_left aux init m | E_look_up dsi -> let%bind (ds', i') = bind_map_pair f dsi in - return (E_constant ("GET", [i' ; ds']), tv) + return @@ E_constant ("GET", [i' ; ds']) | E_matching (expr, m) -> ( let%bind expr' = translate_annotated_expression env expr in match m with | AST.Match_bool {match_true ; match_false} -> let%bind (t, f) = bind_map_pair (translate_annotated_expression env) (match_true, match_false) in - return (E_Cond (expr', t, f), tv) + return @@ E_Cond (expr', t, f) | AST.Match_list _ | AST.Match_option _ | AST.Match_tuple (_, _) -> simple_fail "only match bool exprs are translated yet" ) @@ -336,7 +350,7 @@ and translate_lambda_shallow : Mini_c.Environment.t -> AST.lambda -> Mini_c.expr let%bind output_type' = translate_type output_type in let tv = Combinators.t_shallow_closure env input_type' output_type' in let content = {binder;input=input_type';output=output_type';body;result;capture_type} in - ok (E_function content, tv, env) + ok @@ Combinators.Expression.make_tpl (E_function content, tv, env) and translate_lambda env l = let { binder ; input_type ; output_type ; body ; result } : AST.lambda = l in @@ -359,7 +373,7 @@ and translate_lambda env l = let%bind output = translate_type output_type in let tv = Combinators.t_function input output in let content = {binder;input;output;body=body';result=result';capture_type} in - ok (E_literal (D_function {capture=None;content}), tv, env) + ok @@ Combinators.Expression.make_tpl (E_literal (D_function {capture=None;content}), tv, env) ) | _ -> ( trace (simple_error "translate lambda shallow") @@ @@ -369,7 +383,8 @@ and translate_lambda env l = let translate_declaration env (d:AST.declaration) : toplevel_statement result = match d with | Declaration_constant {name;annotated_expression} -> - let%bind ((_, tv, _) as expression) = translate_annotated_expression env annotated_expression in + let%bind expression = translate_annotated_expression env annotated_expression in + let tv = Combinators.Expression.get_type expression in let env' = Environment.add (name, tv) env in ok @@ ((name, expression), environment_wrap env env') @@ -383,8 +398,8 @@ let translate_program (lst:AST.program) : program result = ok statements let translate_main (l:AST.lambda) (_t:AST.type_value) : anon_function result = - let%bind (expr, _, _) = translate_lambda Environment.empty l in - match expr with + let%bind expr = translate_lambda Environment.empty l in + match Combinators.Expression.get_content expr with | E_literal (D_function f) -> ok f | _ -> simple_fail "main is not a function"