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

fix ligodity issues

Browse Source
This commit is contained in:
Galfour 2019-05-31 22:03:06 +00:00
parent 320d0c1a72
commit 055bee804e
8 changed files with 83 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/contracts/counter.mligo
View File

@ -1,4 +1,4 @@
type storage = int
let%entry main (p:int) storage =
(list [] : operation list , p + storage)
((list [] : operation list) , p + storage)

3
src/contracts/type-alias.ligo Normal file
View File

@ -0,0 +1,3 @@
type toto is int
const foo : toto = 23

204
src/main/contract.ml
View File

@ -1,204 +0,0 @@
open Trace
include struct
open Ast_simplified
let assert_entry_point_defined : program -> string -> unit result =
fun program entry_point ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_type _ -> false
| Declaration_constant (name , _ , _) -> name = entry_point
in
trace_strong (simple_error "no entry-point with given name") @@
Assert.assert_true @@ List.exists aux @@ List.map Location.unwrap program
end
include struct
open Ast_typed
open Combinators
let get_entry_point_type : type_value -> (type_value * type_value) result = fun t ->
let%bind (arg , result) =
trace_strong (simple_error "entry-point doesn't have a function type") @@
get_t_function t in
let%bind (arg' , storage_param) =
trace_strong (simple_error "entry-point doesn't have 2 parameters") @@
get_t_pair arg in
let%bind (ops , storage_result) =
trace_strong (simple_error "entry-point doesn't have 2 results") @@
get_t_pair result in
let%bind () =
trace_strong (simple_error "entry-point doesn't have a list of operation as first result") @@
assert_t_list_operation ops in
let%bind () =
trace_strong (simple_error "entry-point doesn't identitcal type (storage) for second parameter and second result") @@
assert_type_value_eq (storage_param , storage_result) in
ok (arg' , storage_param)
let get_entry_point : program -> string -> (type_value * type_value) result = fun p e ->
let%bind declaration = get_declaration_by_name p e in
match declaration with
| Declaration_constant (d , _) -> get_entry_point_type d.annotated_expression.type_annotation
let assert_valid_entry_point = fun p e ->
let%bind _ = get_entry_point p e in
ok ()
end
let transpile_value
(e:Ast_typed.annotated_expression) : Mini_c.value result =
let%bind f =
let open Transpiler in
let (f , _) = functionalize e in
let%bind main = translate_main f in
ok main
in
let input = Mini_c.Combinators.d_unit in
let%bind r = Run_mini_c.run_entry f input in
ok r
let parsify_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Pascaligo.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Pascaligo.simpl_program raw in
ok simplified
let parsify_expression_pascaligo = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Pascaligo.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Pascaligo.simpl_expression raw in
ok simplified
let parsify_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing") @@
Parser.Ligodity.parse_file source in
let%bind simplified =
trace (simple_error "simplifying") @@
Simplify.Ligodity.simpl_program raw in
ok simplified
let parsify_expression_ligodity = fun source ->
let%bind raw =
trace (simple_error "parsing expression") @@
Parser.Ligodity.parse_expression source in
let%bind simplified =
trace (simple_error "simplifying expression") @@
Simplify.Ligodity.simpl_expression raw in
ok simplified
let parsify = fun syntax source ->
let%bind parsify = match syntax with
| "pascaligo" -> ok parsify_pascaligo
| "cameligo" -> ok parsify_ligodity
| _ -> simple_fail "unrecognized parser"
in
parsify source
let parsify_expression = fun syntax source ->
let%bind parsify = match syntax with
| "pascaligo" -> ok parsify_expression_pascaligo
| "cameligo" -> ok parsify_expression_ligodity
| _ -> simple_fail "unrecognized parser"
in
parsify source
let compile_contract_file : string -> string -> string -> string result = fun source entry_point syntax ->
let%bind simplified = parsify syntax source in
let%bind () =
assert_entry_point_defined simplified entry_point in
let%bind typed =
trace (simple_error "typing") @@
Typer.type_program simplified in
let%bind mini_c =
trace (simple_error "transpiling") @@
Transpiler.translate_entry typed entry_point in
let%bind michelson =
trace (simple_error "compiling") @@
Compiler.translate_contract mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
let compile_contract_parameter : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
let%bind (program , parameter_tv) =
let%bind simplified = parsify syntax source in
let%bind () =
assert_entry_point_defined simplified entry_point in
let%bind typed =
trace (simple_error "typing file") @@
Typer.type_program simplified in
let%bind (param_ty , _) =
get_entry_point typed entry_point in
ok (typed , param_ty)
in
let%bind expr =
let%bind typed =
let%bind simplified = parsify_expression syntax expression in
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
in
trace (simple_error "typing expression") @@
Typer.type_expression env simplified in
let%bind () =
trace (simple_error "expression type doesn't match type parameter") @@
Ast_typed.assert_type_value_eq (parameter_tv , typed.type_annotation) in
let%bind mini_c =
trace (simple_error "transpiling expression") @@
transpile_value typed in
let%bind michelson =
trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
in
ok expr
let compile_contract_storage : string -> string -> string -> string -> string result = fun source entry_point expression syntax ->
let%bind (program , storage_tv) =
let%bind simplified = parsify syntax source in
let%bind () =
assert_entry_point_defined simplified entry_point in
let%bind typed =
trace (simple_error "typing file") @@
Typer.type_program simplified in
let%bind (_ , storage_ty) =
get_entry_point typed entry_point in
ok (typed , storage_ty)
in
let%bind expr =
let%bind simplified = parsify_expression syntax expression in
let%bind typed =
let env =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , (_ , post_env)) -> post_env
in
trace (simple_error "typing expression") @@
Typer.type_expression env simplified in
let%bind () =
trace (simple_error "expression type doesn't match type storage") @@
Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in
let%bind mini_c =
trace (simple_error "transpiling expression") @@
transpile_value typed in
let%bind michelson =
trace (simple_error "compiling expression") @@
Compiler.translate_value mini_c in
let str =
Format.asprintf "%a" Michelson.pp_stripped michelson in
ok str
in
ok expr

19
src/parser/ligodity.ml
View File

@ -4,15 +4,18 @@ module Parser = Parser_ligodity.Parser
module AST = Parser_ligodity.AST
let parse_file (source: string) : AST.t result =
(* let pp_input =
* let prefix = Filename.(source |> basename |> remove_extension)
* and suffix = ".pp.ligo"
* in prefix ^ suffix in *)
(* let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s"
* source pp_input in
* let%bind () = sys_command cpp_cmd in *)
let pp_input =
let prefix = Filename.(source |> basename |> remove_extension)
and suffix = ".pp.ligo"
in prefix ^ suffix in
let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s"
source pp_input in
let%bind () = sys_command cpp_cmd in
source
in
let%bind channel =
generic_try (simple_error "error opening file") @@
(fun () -> open_in pp_input) in

1
src/parser/ligodity/AST.mli
View File

@ -486,3 +486,4 @@ val unpar : expr -> expr
val print_projection : projection -> unit
val print_pattern : pattern -> unit
val print_expr : expr -> unit

43
src/simplify/ligodity.ml
View File

@ -100,6 +100,14 @@ let rec simpl_expression :
let mk_let_in binder rhs result =
E_let_in {binder; rhs; result} in
trace (
let title () = "simplifying expression" in
let message () = "" in
let data = [
("expression" , thunk @@ Format.asprintf "%a" (PP_helpers.printer Raw.print_expr) t)
] in
error ~data title message
) @@
match t with
| Raw.ELetIn e -> (
let Raw.{binding; body; _} = e.value in
@ -194,7 +202,7 @@ let rec simpl_expression :
| EString _ -> simple_fail "string: not supported yet"
| ELogic l -> simpl_logic_expression ?te_annot l
| EList l -> simpl_list_expression ?te_annot l
| ECase c ->
| ECase c -> (
let%bind e = simpl_expression c.value.expr in
let%bind lst =
let aux (x : Raw.expr Raw.case_clause) =
@ -204,8 +212,31 @@ let rec simpl_expression :
@@ List.map aux
@@ List.map get_value
@@ npseq_to_list c.value.cases.value in
let%bind cases = simpl_cases lst in
return @@ E_matching (e, cases)
let default_action () =
let%bind cases = simpl_cases lst in
return @@ E_matching (e , cases) in
(* Hack to take care of patterns introduced by `parser/ligodity/Parser.mly` in "norm_fun_expr" *)
match lst with
| [ (pattern , rhs) ] -> (
match pattern with
| Raw.PPar p -> (
let p' = p.value.inside in
match p' with
| Raw.PTyped x -> (
let x' = x.value in
match x'.pattern with
| Raw.PVar y ->
let var_name = y.value in
let%bind type_expr = simpl_type_expression x'.type_expr in
return @@ e_let_in (var_name , Some type_expr) e rhs
| _ -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
| EFun lamb ->
let%bind input_type = bind_map_option
(fun (_,type_expr) -> simpl_type_expression type_expr)
@ -237,6 +268,8 @@ let rec simpl_expression :
let%bind match_true = simpl_expression c.ifso in
let%bind match_false = simpl_expression c.ifnot in
return @@ E_matching (expr, (Match_bool {match_true; match_false}))
and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result =
let return x = ok @@ make_option_typed x te_annot in
match t with
@ -302,7 +335,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu
let {name;type_expr} : Raw.type_decl = x.value in
let%bind type_expression = simpl_type_expression type_expr in
ok @@ loc x @@ Declaration_type (name.value , type_expression)
| LetEntry _ -> simple_fail "no entry point yet"
| LetEntry x (* -> simple_fail "no entry point yet" *)
| Let x -> (
let _, binding = x.value in
let {variable ; lhs_type ; let_rhs} = binding in
@ -392,4 +425,4 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -
)
let simpl_program : Raw.ast -> program result = fun t ->
bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl
bind_list @@ List.map simpl_declaration @@ List.rev @@ nseq_to_list t.decl

9
src/test/integration_tests.ml
View File

@ -4,9 +4,13 @@ open Test_helpers
open Ast_simplified.Combinators
let mtype_file = type_file "cameligo"
let mtype_file ?debug_simplify ?debug_typed = type_file ?debug_simplify ?debug_typed "cameligo"
let type_file = type_file "pascaligo"
let type_alias () : unit result =
let%bind program = type_file "./contracts/type-alias.ligo" in
expect_eq_evaluate program "foo" (e_int 23)
let function_ () : unit result =
let%bind program = type_file "./contracts/function.ligo" in
let make_expect = fun n -> n in
@ -436,7 +440,7 @@ let dispatch_counter_contract () : unit result =
expect_eq_n program "main" make_input make_expected
let basic_mligo () : unit result =
let%bind typed = mtype_file "./contracts/basic.mligo" in
let%bind typed = mtype_file ~debug_simplify:true "./contracts/basic.mligo" in
let%bind result = evaluate_typed "foo" typed in
Ligo.AST_Typed.assert_value_eq (Ligo.AST_Typed.Combinators.e_a_empty_int (42 + 127), result)
@ -453,6 +457,7 @@ let guess_the_hash_mligo () : unit result =
expect_eq_n program "main" make_input make_expected
let main = "Integration (End to End)", [
test "type alias" type_alias ;
test "function" function_ ;
test "assign" assign ;
test "declaration local" declaration_local ;

29
src/typer/typer.ml
View File

@ -357,16 +357,31 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
} -> (
let%bind input_type =
let%bind input_type =
trace_option (simple_error "no input type provided") @@
input_type in
(* Hack to take care of let_in introduced by `simplify/ligodity.ml` in ECase's hack *)
let default_action () = simple_fail "no input type provided" in
match input_type with
| Some ty -> ok ty
| None -> (
match result with
| I.E_let_in li -> (
match li.rhs with
| I.E_variable name when name = (fst binder) -> (
match snd li.binder with
| Some ty -> ok ty
| None -> default_action ()
)
| _ -> default_action ()
)
| _ -> default_action ()
)
in
evaluate_type e input_type in
let%bind output_type =
let%bind output_type =
trace_option (simple_error "no output type provided") @@
output_type in
evaluate_type e output_type in
bind_map_option (evaluate_type e) output_type
in
let e' = Environment.add_ez_binder (fst binder) input_type e in
let%bind result = type_expression ~tv_opt:output_type e' result in
let%bind result = type_expression ?tv_opt:output_type e' result in
let output_type = result.type_annotation in
return (E_lambda {binder = fst binder;input_type;output_type;result}) (t_function input_type output_type ())
)
| E_constant (name, lst) ->