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

refactor: mini_c expression built and access through combinators

Browse Source
This commit is contained in:
Galfour 2019-04-19 07:59:16 +00:00
parent 0521c3d3b7
commit eaf749cbc5
10 changed files with 218 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/ligo/mini_c/PP.ml
View File

@ -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"

76
src/ligo/mini_c/combinators.ml
View File

@ -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

51
src/ligo/mini_c/combinators_smart.ml Normal file
View File

@ -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

56
src/ligo/mini_c/compiler.ml
View File

@ -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

26
src/ligo/mini_c/compiler_environment.ml
View File

@ -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 =

2
src/ligo/mini_c/dune
View File

@ -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 ))
)

5
src/ligo/mini_c/mini_c.ml
View File

@ -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

4
src/ligo/mini_c/run.ml
View File

@ -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")

7
src/ligo/mini_c/types.ml
View File

@ -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

145
src/ligo/transpiler.ml
View File

@ -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"