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

more basic structure

Browse Source
This commit is contained in:
Galfour 2019-03-24 17:35:43 +00:00
parent ccd4a17aac
commit 47c8e96e95
12 changed files with 327 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/ligo/ast_simplified.ml
View File

@ -477,3 +477,14 @@ module Simplify = struct
let simpl_program (t:Raw.ast) : program result =
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl
end
module Combinators = struct
let annotated_expression ?type_annotation expression = {expression ; type_annotation}
let number n : expression = Literal (Number n)
let record (lst : (string * ae) list) : expression =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
Record map
end

100
src/ligo/ast_typed.ml
View File

@ -283,62 +283,76 @@ let merge_annotation (a:type_value option) (b:type_value option) : type_value re
| None, Some _ -> ok b
| _ -> simple_fail "both have simplified ASTs"
let t_bool s : type_value = type_value (Type_constant ("bool", [])) s
let simplify_t_bool s = t_bool (Some s)
let make_t_bool = t_bool None
module Combinators = struct
let t_string s : type_value = type_value (Type_constant ("string", [])) s
let simplify_t_string s = t_string (Some s)
let make_t_string = t_string None
let t_bool s : type_value = type_value (Type_constant ("bool", [])) s
let simplify_t_bool s = t_bool (Some s)
let make_t_bool = t_bool None
let t_bytes s : type_value = type_value (Type_constant ("bytes", [])) s
let simplify_t_bytes s = t_bytes (Some s)
let make_t_bytes = t_bytes None
let t_string s : type_value = type_value (Type_constant ("string", [])) s
let simplify_t_string s = t_string (Some s)
let make_t_string = t_string None
let t_int s : type_value = type_value (Type_constant ("int", [])) s
let simplify_t_int s = t_int (Some s)
let make_t_int = t_int None
let t_bytes s : type_value = type_value (Type_constant ("bytes", [])) s
let simplify_t_bytes s = t_bytes (Some s)
let make_t_bytes = t_bytes None
let t_unit s : type_value = type_value (Type_constant ("unit", [])) s
let simplify_t_unit s = t_unit (Some s)
let make_t_unit = t_unit None
let t_int s : type_value = type_value (Type_constant ("int", [])) s
let simplify_t_int s = t_int (Some s)
let make_t_int = t_int None
let t_tuple lst s : type_value = type_value (Type_tuple lst) s
let simplify_t_tuple lst s = t_tuple lst (Some s)
let make_t_tuple lst = t_tuple lst None
let t_unit s : type_value = type_value (Type_constant ("unit", [])) s
let simplify_t_unit s = t_unit (Some s)
let make_t_unit = t_unit None
let t_record m s : type_value = type_value (Type_record m) s
let make_t_record m = t_record m None
let t_tuple lst s : type_value = type_value (Type_tuple lst) s
let simplify_t_tuple lst s = t_tuple lst (Some s)
let make_t_tuple lst = t_tuple lst None
let t_sum m s : type_value = type_value (Type_sum m) s
let make_t_sum m = t_sum m None
let t_record m s : type_value = type_value (Type_record m) s
let make_t_ez_record (lst:(string * type_value) list) : type_value =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
type_value (Type_record map) None
let t_function (param, result) s : type_value = type_value (Type_function (param, result)) s
let make_t_function f = t_function f None
let make_t_record m = t_record m None
let get_annotation (x:annotated_expression) = x.type_annotation
let t_sum m s : type_value = type_value (Type_sum m) s
let make_t_sum m = t_sum m None
let get_t_bool (t:type_value) : unit result = match t.type_value with
| Type_constant ("bool", []) -> ok ()
| _ -> simple_fail "not a bool"
let t_function (param, result) s : type_value = type_value (Type_function (param, result)) s
let make_t_function f = t_function f None
let get_t_option (t:type_value) : type_value result = match t.type_value with
| Type_constant ("option", [o]) -> ok o
| _ -> simple_fail "not a option"
let get_annotation (x:annotated_expression) = x.type_annotation
let get_t_list (t:type_value) : type_value result = match t.type_value with
| Type_constant ("list", [o]) -> ok o
| _ -> simple_fail "not a list"
let get_t_bool (t:type_value) : unit result = match t.type_value with
| Type_constant ("bool", []) -> ok ()
| _ -> simple_fail "not a bool"
let get_t_tuple (t:type_value) : type_value list result = match t.type_value with
| Type_tuple lst -> ok lst
| _ -> simple_fail "not a tuple"
let get_t_option (t:type_value) : type_value result = match t.type_value with
| Type_constant ("option", [o]) -> ok o
| _ -> simple_fail "not a option"
let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value with
| Type_sum m -> ok m
| _ -> simple_fail "not a sum"
let get_t_list (t:type_value) : type_value result = match t.type_value with
| Type_constant ("list", [o]) -> ok o
| _ -> simple_fail "not a list"
let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value with
| Type_record m -> ok m
| _ -> simple_fail "not a record"
let get_t_tuple (t:type_value) : type_value list result = match t.type_value with
| Type_tuple lst -> ok lst
| _ -> simple_fail "not a tuple"
let get_t_sum (t:type_value) : type_value SMap.t result = match t.type_value with
| Type_sum m -> ok m
| _ -> simple_fail "not a sum"
let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value with
| Type_record m -> ok m
| _ -> simple_fail "not a record"
let record (lst : (string * ae) list) : expression =
let aux prev (k, v) = SMap.add k v prev in
let map = List.fold_left aux SMap.empty lst in
Record map
let int n : expression = Literal (Int n)
end

2
src/ligo/ligo.ml
View File

@ -6,6 +6,8 @@ module AST_Raw = AST
module AST_Simplified = Ast_simplified
module AST_Typed = Ast_typed
module Mini_c = Mini_c
module Typer = Typer
module Transpiler = Transpiler
open Ligo_helpers.Trace
let parse_file (source:string) : AST_Raw.t result =

77
src/ligo/mini_c.ml
View File

@ -35,6 +35,11 @@ and environment_small = environment_element Append_tree.t
and environment = environment_small list
type environment_wrap = {
pre_environment : environment ;
post_environment : environment ;
}
type var_name = string
type fun_name = string
@ -68,9 +73,9 @@ and statement' =
| Cond of expression * block * block
| While of expression * block
and statement = statement' * environment (* Environment after the statement *)
and statement = statement' * environment_wrap
and toplevel_statement = assignment * environment (* Same *)
and toplevel_statement = assignment * environment_wrap
and anon_function_content = {
binder : string ;
@ -95,7 +100,7 @@ and capture =
and block' = statement list
and block = block' * environment (* Environment at the beginning of the block *)
and block = block' * environment_wrap
and program = toplevel_statement list
@ -787,16 +792,16 @@ module Translate_program = struct
in
ok code
and translate_statement ((s', env) as s:statement) : michelson result =
and translate_statement ((s', w_env) as s:statement) : michelson result =
let error_message = Format.asprintf "%a" PP.statement s in
let%bind (code : michelson) =
trace (error "translating statement" error_message) @@ match s' with
| Assignment (s, ((_, tv, _) as expr)) ->
let%bind expr = translate_expression expr in
let%bind add =
if Environment.has s env
then Environment.to_michelson_set s env
else Environment.to_michelson_add (s, tv) env
if Environment.has s w_env.pre_environment
then Environment.to_michelson_set s w_env.pre_environment
else Environment.to_michelson_add (s, tv) w_env.pre_environment
in
ok (seq [
i_comment "assignment" ;
@ -838,7 +843,7 @@ module Translate_program = struct
ok (instruction :: lst)
in
let%bind error_message =
let%bind schema_michelson = Environment.to_michelson_type env in
let%bind schema_michelson = Environment.to_michelson_type env.pre_environment in
ok @@ Format.asprintf "\nblock : %a\nschema : %a\n"
PP.block (b, env)
Tezos_utils.Micheline.Michelson.pp schema_michelson
@ -1025,4 +1030,60 @@ module Combinators = struct
| `Right b -> ok (true, b)
| _ -> simple_fail "not a left/right"
let get_last_statement ((b', _):block) : statement result =
let aux lst = match lst with
| [] -> simple_fail "get_last: empty list"
| lst -> ok List.(nth lst (length lst - 1)) in
aux b'
let t_int : type_value = `Base Int
let quote binder input output body result : anon_function =
let content : anon_function_content = {
binder ; input ; output ;
body ; result ; capture_type = No_capture ;
} in
{ content ; capture = None }
let basic_quote i o b : anon_function result =
let%bind (_, e) = get_last_statement b in
let r : expression = (Var "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 = Environment.empty in
Environment.add ("input", t_int) e
let expr_int expr env : expression = (expr, t_int, env)
let var_int name env : expression = expr_int (Var name) env
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
| Cond _ -> s', id_environment_wrap e
| While _ -> s', id_environment_wrap e
| Assignment (name, (_, t, _)) -> s', environment_wrap e (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 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
end

44
src/ligo/test/compiler_tests.ml Normal file
View File

@ -0,0 +1,44 @@
open Ligo_helpers.Trace
open Ligo.Mini_c
open Combinators
open Test_helpers
let run_entry_int (e:anon_function) (n:int) : int result =
let param : value = `Int n in
let%bind result = Run.run_entry e param in
match result with
| `Int n -> ok n
| _ -> simple_fail "result is not an int"
let identity () : unit result =
let e = basic_int_quote_env in
let s = statement (Assignment ("output", var_int "input" e)) e in
let%bind b = block [s] in
let%bind f = basic_int_quote b in
let%bind result = run_entry_int f 42 in
let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in
ok ()
let multiple_vars () : unit result =
let e = basic_int_quote_env in
(*
Statements can change the environment, and you don't want to pass the new environment manually.
[statements] deals with this and this is why those statements are parametrized over an environment.
Yes. One could do a monad. Feel free when we have the time.
*)
let ss = statements [
(fun e -> statement (Assignment ("a", var_int "input" e)) e) ;
(fun e -> statement (Assignment ("b", var_int "input" e)) e) ;
(fun e -> statement (Assignment ("c", var_int "a" e)) e) ;
(fun e -> statement (Assignment ("output", var_int "c" e)) e) ;
] e in
let%bind b = block ss in
let%bind f = basic_int_quote b in
let%bind result = run_entry_int f 42 in
let%bind _ = Assert.assert_equal_int ~msg:__LOC__ 42 result in
ok ()
let main = "Compiler (from Mini_C)", [
test "identity" identity ;
test "multiple_vars" multiple_vars ;
]

35
src/ligo/test/integration_tests.ml Normal file
View File

@ -0,0 +1,35 @@
open Ligo_helpers.Trace
open Ligo
open Test_helpers
let pass (source:string) : unit result =
let%bind raw =
trace (simple_error "parsing") @@
parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
simplify raw in
let%bind typed =
trace (simple_error "typing") @@
type_ simplified in
let%bind mini_c =
trace (simple_error "transpiling") @@
transpile typed in
Format.printf "mini_c code : %a" Mini_c.PP.program mini_c ;
ok ()
let basic () : unit result =
Format.printf "basic test" ;
pass "./contracts/toto.ligo"
let function_ () : unit result =
Format.printf "function test" ;
let%bind _ = pass "./contracts/function.ligo" in
let%bind result = easy_run_main "./contracts/function.ligo" "2" in
Format.printf "result : %a" AST_Typed.PP.annotated_expression result ;
ok ()
let main = "Integration (End to End)", [
test "basic" basic ;
test "function" function_ ;
]

59
src/ligo/test/test.ml
View File

@ -1,62 +1,11 @@
(* -*- compile-command: "cd .. ; dune runtest" -*- *)
open Ligo_helpers.Trace
open Ligo
let test name f =
Alcotest.test_case name `Quick @@ fun _sw ->
match f () with
| Ok () -> ()
| Errors errs ->
Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
raise Alcotest.Test_error
module Ligo = struct
let pass (source:string) : unit result =
let%bind raw =
trace (simple_error "parsing") @@
parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
simplify raw in
let%bind typed =
trace (simple_error "typing") @@
type_ simplified in
let%bind mini_c =
trace (simple_error "transpiling") @@
transpile typed in
Format.printf "mini_c code : %a" Mini_c.PP.program mini_c ;
ok ()
let basic () : unit result =
Format.printf "basic test" ;
pass "./contracts/toto.ligo"
let function_ () : unit result =
Format.printf "function test" ;
let%bind _ = pass "./contracts/function.ligo" in
let%bind result = easy_run_main "./contracts/function.ligo" "2" in
Format.printf "result : %a" AST_Typed.PP.annotated_expression result ;
ok ()
(* let display_basic () : unit result =
* parse_file "./contracts/toto.ligo" >>? fun program_ast ->
* Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program ->
* Ligo.Transpile.program_to_michelson typed_program >>? fun node ->
* let node = Tezos_utils.Cast.flatten_node node in
* let str = Tezos_utils.Cast.node_to_string node in
* Format.printf "Program:\n%s\n%!" str ;
* ok () *)
let main = "Ligo", [
test "basic" basic ;
test "function" function_ ;
]
end
let () =
(* Printexc.record_backtrace true ; *)
Alcotest.run "LIGO" [
Ligo.main ;
Integration_tests.main ;
Compiler_tests.main ;
Transpiler_tests.main ;
Typer_tests.main ;
] ;
()

9
src/ligo/test/test_helpers.ml Normal file
View File

@ -0,0 +1,9 @@
open Ligo_helpers.Trace
let test name f =
Alcotest.test_case name `Quick @@ fun () ->
match f () with
| Ok () -> ()
| Errors errs ->
Format.printf "Errors : {\n%a}\n%!" errors_pp errs ;
raise Alcotest.Test_error

9
src/ligo/test/transpiler_tests.ml Normal file
View File

@ -0,0 +1,9 @@
(* open Ligo_helpers.Trace
* open Ligo.Mini_c
* open Combinators
* open Test_helpers *)
(* How should one test the transpiler? *)
let main = "Transpiler (from Mini_C)", [
]

40
src/ligo/test/typer_tests.ml Normal file
View File

@ -0,0 +1,40 @@
open Ligo_helpers.Trace
open Ligo.AST_Simplified
open Test_helpers
module Typed = Ligo.AST_Typed
module Typer = Ligo.Typer
let int () : unit result =
let open Combinators in
let pre = ae @@ number 32 in
let open Typer in
let e = Environment.empty in
let%bind post = type_annotated_expression e pre in
let open Typed in
let open Combinators in
let%bind () = assert_type_value_eq (post.type_annotation, make_t_int) in
ok ()
let record () : unit result =
let open Combinators in
let pre = ae (record [
("foo", ae @@ number 32) ;
("bar", ae @@ number 23) ;
]) in
let open Typer in
let%bind post = type_annotated_expression Environment.empty pre in
let open Typed in
let open Combinators in
let result_type = make_t_ez_record [
("foo", make_t_int) ;
("bar", make_t_int) ;
] in
let%bind () = assert_type_value_eq (post.type_annotation, result_type) in
ok ()
let main = "Typer (from simplified AST)", [
test "int" int ;
test "record" record ;
]

46
src/ligo/transpiler.ml
View File

@ -1,7 +1,9 @@
open! Ligo_helpers.Trace
open Mini_c
open Combinators
module AST = Ast_typed
open AST.Combinators
let list_of_map m = List.rev @@ Ligo_helpers.X_map.String.fold (fun _ v prev -> v :: prev) m []
let kv_list_of_map m = List.rev @@ Ligo_helpers.X_map.String.fold (fun k v prev -> (k, v) :: prev) m []
@ -46,27 +48,37 @@ let rec translate_type (t:AST.type_value) : type_value result =
let rec translate_block env (b:AST.block) : block result =
let env' = Environment.extend env in
let%bind instructionss = bind_list @@ List.map (translate_instruction env) b in
let instructions = List.concat instructionss in
ok (instructions, env')
let%bind (instructions, env') =
let rec aux e acc lst = match lst with
| [] -> ok (acc, e)
| hd :: tl ->
match%bind translate_instruction e hd with
| Some ((_, e') as i) -> aux e'.post_environment (i :: acc) tl
| None -> aux e acc tl
in
let%bind (lst, e) = aux env' [] b in
ok (List.rev lst, e)
in
ok (instructions, environment_wrap env env')
and translate_instruction (env:Environment.t) (i:AST.instruction) : statement list result =
let return x = ok [x] in
and translate_instruction (env:Environment.t) (i:AST.instruction) : statement option result =
let return ?(env' = env) x : statement option result = ok (Some (x, environment_wrap env env')) in
match i with
| Assignment {name;annotated_expression} ->
let%bind expression = translate_annotated_expression env annotated_expression in
return (Assignment (name, expression), env)
let%bind (_, t, _) as expression = translate_annotated_expression env annotated_expression in
let env' = Environment.add (name, t) env in
return ~env' (Assignment (name, expression))
| Matching (expr, Match_bool {match_true ; match_false}) ->
let%bind expr' = translate_annotated_expression env expr in
let%bind true_branch = translate_block env match_true in
let%bind false_branch = translate_block env match_false in
return (Cond (expr', true_branch, false_branch), env)
return (Cond (expr', true_branch, false_branch))
| Matching _ -> simple_fail "todo : match"
| Loop (expr, body) ->
let%bind expr' = translate_annotated_expression env expr in
let%bind body' = translate_block env body in
return (While (expr', body'), env)
| Skip -> ok []
return (While (expr', body'))
| Skip -> ok None
| Fail _ -> simple_fail "todo : fail"
and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_expression) : expression result =
@ -85,7 +97,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
ok (Apply (a, b), tv, env)
| Constructor (m, param) ->
let%bind (param'_expr, param'_tv, _) = translate_annotated_expression env ae in
let%bind map_tv = AST.get_t_sum ae.type_annotation 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 =
@ -123,7 +135,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
Append_tree.fold_ne (translate_annotated_expression env) aux node
| Tuple_accessor (tpl, ind) ->
let%bind (tpl'_expr, _, _) = translate_annotated_expression env tpl in
let%bind tpl_tv = AST.get_t_tuple ae.type_annotation in
let%bind tpl_tv = get_t_tuple ae.type_annotation in
let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (a, i)) tpl_tv in
let%bind ae' =
let leaf (tv, i) : (expression' option * type_value) result =
@ -157,7 +169,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
Append_tree.fold_ne (translate_annotated_expression env) aux node
| Record_accessor (r, key) ->
let%bind (r'_expr, _, _) = translate_annotated_expression env r in
let%bind r_tv = AST.get_t_record ae.type_annotation in
let%bind r_tv = get_t_record ae.type_annotation in
let node_tv = Append_tree.of_list @@ kv_list_of_map r_tv in
let%bind ae' =
let leaf (key', tv) : (expression' option * type_value) result =
@ -204,8 +216,8 @@ and translate_lambda env l tv =
let%bind input = translate_type input_type in
let sub_env = Environment.extend env in
let full_env = Environment.add (binder, input) sub_env in
let%bind (_, post_env) as body = translate_block full_env body in
let%bind result = translate_annotated_expression post_env result in
let%bind (_, e) as body = translate_block full_env body in
let%bind result = translate_annotated_expression e.post_environment result in
let capture_type = Shallow_capture sub_env in
let input = Environment.to_mini_c_type full_env in
let%bind output = translate_type output_type in
@ -217,13 +229,13 @@ let translate_declaration env (d:AST.declaration) : toplevel_statement result =
| Constant_declaration {name;annotated_expression} ->
let%bind ((_, tv, _) as expression) = translate_annotated_expression env annotated_expression in
let env' = Environment.add (name, tv) env in
ok @@ ((name, expression), env')
ok @@ ((name, expression), environment_wrap env env')
let translate_program (lst:AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =
let%bind (tl, env) = prev in
let%bind ((_, env') as cur') = translate_declaration env cur in
ok (cur' :: tl, env')
ok (cur' :: tl, env'.post_environment)
in
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) lst in
ok statements

35
src/ligo/typer.ml
View File

@ -2,6 +2,7 @@ open Ligo_helpers.Trace
module I = Ast_simplified
module O = Ast_typed
open O.Combinators
module SMap = O.SMap
@ -102,7 +103,7 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc
| Loop (cond, body) ->
let%bind cond = type_annotated_expression e cond in
let%bind _ =
O.assert_type_value_eq (cond.type_annotation, O.make_t_bool) in
O.assert_type_value_eq (cond.type_annotation, make_t_bool) in
let%bind body = type_block e body in
ok (e, O.Loop (cond, body))
| Assignment {name;annotated_expression} -> (
@ -135,14 +136,14 @@ and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching resul
| Match_bool {match_true ; match_false} ->
let%bind _ =
trace_strong (simple_error "Matching bool on not-a-bool")
@@ O.get_t_bool t in
@@ get_t_bool t in
let%bind match_true = type_block e match_true in
let%bind match_false = type_block e match_false in
ok (O.Match_bool {match_true ; match_false})
| Match_option {match_none ; match_some} ->
let%bind t_opt =
trace_strong (simple_error "Matching option on not-an-option")
@@ O.get_t_option t in
@@ get_t_option t in
let%bind match_none = type_block e match_none in
let (n, b) = match_some in
let e' = Environment.add e n t_opt in
@ -151,7 +152,7 @@ and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching resul
| Match_list {match_nil ; match_cons} ->
let%bind t_list =
trace_strong (simple_error "Matching list on not-an-list")
@@ O.get_t_list t in
@@ get_t_list t in
let%bind match_nil = type_block e match_nil in
let (hd, tl, b) = match_cons in
let e' = Environment.add e hd t_list in
@ -161,7 +162,7 @@ and type_match (e:environment) (t:O.type_value) : I.matching -> O.matching resul
| Match_tuple (lst, b) ->
let%bind t_tuple =
trace_strong (simple_error "Matching tuple on not-a-tuple")
@@ O.get_t_tuple t in
@@ get_t_tuple t in
let%bind _ =
trace_strong (simple_error "Matching tuple of different size")
@@ Assert.assert_list_same_size t_tuple lst in
@ -220,29 +221,29 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
let%bind type_annotation = check tv' in
ok O.{expression = Variable name ; type_annotation}
| Literal (Bool b) ->
let%bind type_annotation = check O.make_t_bool in
let%bind type_annotation = check make_t_bool in
ok O.{expression = Literal (Bool b) ; type_annotation }
| Literal Unit ->
let%bind type_annotation = check O.make_t_unit in
let%bind type_annotation = check make_t_unit in
ok O.{expression = Literal (Unit) ; type_annotation }
| Literal (String s) ->
let%bind type_annotation = check O.make_t_string in
let%bind type_annotation = check make_t_string in
ok O.{expression = Literal (String s) ; type_annotation }
| Literal (Bytes s) ->
let%bind type_annotation = check O.make_t_bytes in
let%bind type_annotation = check make_t_bytes in
ok O.{expression = Literal (Bytes s) ; type_annotation }
| Literal (Number n) ->
let%bind type_annotation = check O.make_t_int in
let%bind type_annotation = check make_t_int in
ok O.{expression = Literal (Int n) ; type_annotation }
(* Tuple *)
| Tuple lst ->
let%bind lst' = bind_list @@ List.map (type_annotated_expression e) lst in
let tv_lst = List.map O.get_annotation lst' in
let%bind type_annotation = check (O.make_t_tuple tv_lst) in
let tv_lst = List.map get_annotation lst' in
let%bind type_annotation = check (make_t_tuple tv_lst) in
ok O.{expression = Tuple lst' ; type_annotation }
| Tuple_accessor (tpl, ind) ->
let%bind tpl' = type_annotated_expression e tpl in
let%bind tpl_tv = O.get_t_tuple tpl'.type_annotation in
let%bind tpl_tv = get_t_tuple tpl'.type_annotation in
let%bind tv =
generic_try (simple_error "bad tuple index")
@@ (fun () -> List.nth tpl_tv ind) in
@ -265,11 +266,11 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
ok (SMap.add k expr' prev')
in
let%bind m' = SMap.fold aux m (ok SMap.empty) in
let%bind type_annotation = check @@ O.make_t_record (SMap.map O.get_annotation m') in
let%bind type_annotation = check @@ make_t_record (SMap.map get_annotation m') in
ok O.{expression = O.Record m' ; type_annotation }
| Record_accessor (r, ind) ->
let%bind r' = type_annotated_expression e r in
let%bind r_tv = O.get_t_record r'.type_annotation in
let%bind r_tv = get_t_record r'.type_annotation in
let%bind tv =
generic_try (simple_error "bad record index")
@@ (fun () -> SMap.find ind r_tv) in
@ -287,11 +288,11 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an
let e' = Environment.add e binder input_type in
let%bind result = type_annotated_expression e' result in
let%bind body = type_block e' body in
let%bind type_annotation = check @@ O.make_t_function (input_type, output_type) in
let%bind type_annotation = check @@ make_t_function (input_type, output_type) in
ok O.{expression = Lambda {binder;input_type;output_type;result;body} ; type_annotation}
| Constant (name, lst) ->
let%bind lst' = bind_list @@ List.map (type_annotated_expression e) lst in
let tv_lst = List.map O.get_annotation lst' in
let tv_lst = List.map get_annotation lst' in
let%bind (name', tv) = type_constant name tv_lst in
let%bind type_annotation = check tv in
ok O.{expression = O.Constant (name', lst') ; type_annotation}