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

complete camligo simplify

Browse Source
This commit is contained in:
Galfour 2019-04-27 07:57:51 +00:00
parent d19c0058a7
commit a18dba2049
4 changed files with 48 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
src/ligo/contracts/new-syntax.mligo
View File

@ -1,6 +1,3 @@
(* Smart contract for voting. Winners of vote split the contract
balance at the end of the voting period. *)
(** Type of storage for this contract *)
type storage = {
challenge : string ;
@ -20,4 +17,4 @@ let%entry attempt (p:param) storage =
if Crypto.hash (Bytes.pack p.attempt) <> Bytes.pack storage.challenge then failwith "Failed challenge" ;
let transfer : operation = Operation.transfer (sender , 10tz) in
let storage : storage = storage.challenge <- p.new_challenge in
([] , storage)
((list [] : operation list), storage)

28
src/ligo/parser/camligo/generator.ml
View File

@ -424,8 +424,8 @@ module Pattern = struct
let application = empty_infix "application" `Left
let list : O.n_operator = make_name "list" [
`Token LIST ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
let data_structure : O.n_operator = make_name "data_structure" [
`Named variable_name ; `Token LSQUARE ; `List (Lead SEMICOLON, `Current) ; `Token RSQUARE ;
]
let record_element : O.rule = make_name "p_record_element" [
@ -460,10 +460,11 @@ module Pattern = struct
] []
let main = O.name_hierarchy pattern_name "P" [
[application ; record] ;
[record] ;
[type_annotation] ;
[pair] ;
[list] ;
[data_structure] ;
[application] ;
[variable ; constructor ; module_ident ; unit] ;
[paren "paren" pattern_name]
] []
@ -482,8 +483,8 @@ module Expression = struct
`Current ; `Token COLON ; `Named restricted_type_expression_name
]
let list : O.n_operator = make_name "list" [
`Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
let data_structure : O.n_operator = make_name "data_structure" [
`Named variable_name ; `Token LSQUARE ; `List (Trail SEMICOLON, `Current) ; `Token RSQUARE ;
]
let fun_ : O.n_operator = make_name "fun" [
@ -584,10 +585,10 @@ module Expression = struct
[lt ; le ; gt ; eq ; neq] ;
[assignment] ;
[cons] ;
[application] ;
[addition ; substraction] ;
[multiplication ; division] ;
[list] ;
[application] ;
[data_structure] ;
[name] ;
[arith_variable ; constructor ; module_ident ; accessor ; int ; unit ; string ; tz] ;
[paren "bottom" expression_name] ;
@ -627,7 +628,7 @@ module Type_expression = struct
`Token RBRACKET ;
]
let application = empty_infix "application" `Left
let application = empty_infix "application" `Right
let tuple = make_name "tuple" [
`List (Separated_nene COMMA, `Lower)
@ -636,6 +637,7 @@ module Type_expression = struct
let type_variable : O.n_operator = make_name "variable" [ `Named variable_name ]
let restricted_type_expression = O.name_hierarchy restricted_type_expression_name "Tr" [
[application] ;
[type_variable] ;
[paren "paren" type_expression_name] ;
] []
@ -671,7 +673,6 @@ module Program = struct
]
let type_annotation_name = "type_annotation_"
let type_annotation : O.rule = make_name type_annotation_name [
make_name "" [ `Token COLON ; `Named type_expression_name ] ;
]
@ -687,13 +688,6 @@ module Program = struct
] ;
]
(* let statement : O.rule = make_name statement_name [
* make_name "variable_declaration" [`Token LET ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
* make_name "init_declaration" [`Token LET_INIT ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
* make_name "entry_declaration" [`Token LET_ENTRY ; `List (Naked_ne, param_name) ; `Token EQUAL ; `Named expression_name] ;
* make_name "type_declaration" [`Token TYPE ; `Named variable_name ; `Token EQUAL ; `Named type_expression_name] ;
* ] *)
let statement : O.rule = make_name statement_name [
make_name "variable_declaration" [`Token LET ; `Named let_content_name] ;
make_name "init_declaration" [`Token LET_INIT ; `Named let_content_name] ;

1
src/ligo/parser/camligo/lex/generator.ml
View File

@ -125,7 +125,6 @@ let tokens = [
keyword "if" ;
keyword "then" ;
keyword "else" ;
keyword "list" ;
(* keyword "block" ;
* keyword "for" ;
* keyword "const" ; *)

48
src/ligo/simplify/camligo.ml
View File

@ -53,6 +53,11 @@ let get_p_typed_variable : I.pattern -> (string Location.wrap * I.restricted_typ
let%bind var = get_p_variable (unwrap p') in
ok (var , rte)
let get_eh_accessor : _ -> _ result = fun x ->
match x with
| I.Eh_accessor x -> ok x
| _ -> simple_fail "not a simple eh_accessor"
let get_typed_variable_param : I.param -> _ result = fun arg ->
let%bind up =
let%bind rp = get_param_restricted_pattern arg in
@ -133,14 +138,18 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te
| I.T_variable v -> (
match List.assoc_opt v.wrap_content type_constants with
| Some n -> (
let error expected got =
let title () = "bad arity" in
let content () = Format.asprintf "Expected: %d. Got: %d." expected got in
error title content in
match arg'.wrap_content with
| T_tuple lst -> (
let%bind () =
trace (simple_error "bad arity") @@
trace (error n (List.length lst)) @@
Assert.assert_list_size lst n in
ok @@ O.T_constant (v.wrap_content , lst)
)
| _ -> simple_fail "bad arity"
| e -> ok @@ O.T_constant ((unwrap v) , [ e ])
)
| None -> (
let error =
@ -153,12 +162,15 @@ let rec type_expression : I.type_expression -> O.type_expression result = fun te
)
| _ -> simple_fail "type applying to non-var"
let restricted_type_expression : I.restricted_type_expression -> O.type_expression result = fun rte ->
let rec of_restricted_type_expression : I.restricted_type_expression -> I.type_expression = fun rte ->
let self = of_restricted_type_expression in
match rte with
| Tr_variable tv ->
let%bind tv' = bind_map_location type_variable tv in
ok @@ unwrap tv'
| Tr_paren te -> type_expression (unwrap te)
| Tr_variable tv -> T_variable tv
| Tr_application (a , b) -> T_application (Location.map self a , Location.map self b)
| Tr_paren te -> unwrap te
let restricted_type_expression : I.restricted_type_expression -> O.type_expression result =
Function.compose type_expression of_restricted_type_expression
type last_instruction_result = (O.block * O.annotated_expression)
type lir = last_instruction_result
@ -197,7 +209,7 @@ and let_in_last_instruction :
= fun l ->
let (pat , expr , body) = l in
let%bind (var , ty) = get_p_typed_variable (unwrap pat) in
let%bind ty' = restricted_type_expression (unwrap ty) in
let%bind ty' = type_expression @@ of_restricted_type_expression (unwrap ty) in
let%bind expr' = expression (unwrap expr) in
let%bind uexpr' = get_untyped_expression expr' in
let%bind (body' , last') = expression_last_instruction (unwrap body) in
@ -328,12 +340,24 @@ and expression_main : I.expression_main Location.wrap -> O.annotated_expression
return @@ E_variable (unwrap v)
| Eh_constructor _ ->
simple_fail "constructor without parameter"
| Eh_list _ ->
simple_fail "list not supported yet"
| Eh_data_structure (kind , content) -> (
match unwrap kind with
| "list" -> (
let%bind lst = bind_map_list expression_main content in
ok @@ untyped_expression @@ E_list lst
)
| kind' -> (
let error =
let title () = "data-structures not supported yet" in
let content () = Format.asprintf "%s" kind' in
error title content in
fail error
)
)
| Eh_name _ ->
simple_fail "named parameter not supported yet"
| Eh_assign _ ->
simple_fail "assign not supported yet"
| Eh_assign x ->
simple_binop "ASSIGN" x
| Eh_accessor (src , path) ->
ok @@ O.(untyped_expression @@ e_accessor_props (untyped_expression @@ e_variable (unwrap src)) (List.map unwrap path))
| Eh_bottom e ->