This commit is contained in:
Sander Spies 2020-04-02 10:31:52 +02:00
commit 951235d105
46 changed files with 751 additions and 456 deletions

View File

@ -21,13 +21,13 @@ type timestamp
A date in the real world. A date in the real world.
<SyntaxTitle syntax="pascaligo"> <SyntaxTitle syntax="pascaligo">
type mutez type tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="cameligo"> <SyntaxTitle syntax="cameligo">
type mutez type tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="reasonligo"> <SyntaxTitle syntax="reasonligo">
type mutez type tez
</SyntaxTitle> </SyntaxTitle>
A specific type for tokens. A specific type for tokens.
@ -83,13 +83,13 @@ type chain_id
The identifier of a chain, used to indicate test or main chains. The identifier of a chain, used to indicate test or main chains.
<SyntaxTitle syntax="pascaligo"> <SyntaxTitle syntax="pascaligo">
function balance : mutez function balance : tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="cameligo"> <SyntaxTitle syntax="cameligo">
val balance : mutez val balance : tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="reasonligo"> <SyntaxTitle syntax="reasonligo">
let balance: mutez let balance: tez
</SyntaxTitle> </SyntaxTitle>
Get the balance for the contract. Get the balance for the contract.
@ -263,13 +263,13 @@ let not_tomorrow: bool = (Tezos.now == in_24_hrs);
<SyntaxTitle syntax="pascaligo"> <SyntaxTitle syntax="pascaligo">
function amount : mutez function amount : tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="cameligo"> <SyntaxTitle syntax="cameligo">
val amount : mutez val amount : tez
</SyntaxTitle> </SyntaxTitle>
<SyntaxTitle syntax="reasonligo"> <SyntaxTitle syntax="reasonligo">
let amount: mutez let amount: tez
</SyntaxTitle> </SyntaxTitle>
Get the amount of tez provided by the sender to complete this Get the amount of tez provided by the sender to complete this

View File

@ -2,15 +2,15 @@ import React from 'react';
import styles from './styles.module.css'; import styles from './styles.module.css';
function SyntaxSwitch(props) { function SyntaxSwitch(props) {
return React.createElement("select", { return /*#__PURE__*/React.createElement("select", {
className: styles.syntaxSwitch, className: styles.syntaxSwitch,
defaultValue: props.syntax, defaultValue: props.syntax,
onChange: e => props.onSyntaxChange(e.target.value) onChange: e => props.onSyntaxChange(e.target.value)
}, React.createElement("option", { }, /*#__PURE__*/React.createElement("option", {
value: "pascaligo" value: "pascaligo"
}, "PascaLIGO"), React.createElement("option", { }, "PascaLIGO"), /*#__PURE__*/React.createElement("option", {
value: "cameligo" value: "cameligo"
}, "CameLIGO"), React.createElement("option", { }, "CameLIGO"), /*#__PURE__*/React.createElement("option", {
value: "reasonligo" value: "reasonligo"
}, "ReasonLIGO")); }, "ReasonLIGO"));
} }

View File

@ -2,11 +2,11 @@ import React from 'react';
import SyntaxContext from './SyntaxContext'; import SyntaxContext from './SyntaxContext';
function Syntax(props) { function Syntax(props) {
return React.createElement(SyntaxContext.Consumer, null, syntax => { return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => {
if (syntax === props.syntax) { if (syntax === props.syntax) {
return props.children; return props.children;
} else { } else {
return React.createElement(React.Fragment, null); return /*#__PURE__*/React.createElement(React.Fragment, null);
} }
}); });
} }

View File

@ -32,6 +32,7 @@
.syntaxSwitch option { .syntaxSwitch option {
color: var(--color-primary-text); color: var(--color-primary-text);
font-weight:normal; font-weight:normal;
background-color: var(--ifm-navbar-background-color);
} }

View File

@ -72,9 +72,9 @@ function SyntaxTitle(props) {
useEffect(() => { useEffect(() => {
setMounted(true); setMounted(true);
}, []); }, []);
return React.createElement(SyntaxContext.Consumer, null, syntax => { return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => {
if (syntax === props.syntax) { if (syntax === props.syntax) {
return React.createElement(Highlight, _extends({}, defaultProps, { return /*#__PURE__*/React.createElement(Highlight, _extends({}, defaultProps, {
key: mounted, key: mounted,
language: props.syntax, language: props.syntax,
code: props.children, code: props.children,
@ -85,7 +85,7 @@ function SyntaxTitle(props) {
tokens, tokens,
getLineProps, getLineProps,
getTokenProps getTokenProps
}) => React.createElement("pre", { }) => /*#__PURE__*/React.createElement("pre", {
className: className, className: className,
style: { style: {
backgroundColor: 'var(--ifm-background-color)', backgroundColor: 'var(--ifm-background-color)',
@ -95,15 +95,15 @@ function SyntaxTitle(props) {
whiteSpace: 'break-spaces', whiteSpace: 'break-spaces',
marginTop: '3rem' marginTop: '3rem'
} }
}, tokens.map((line, i) => React.createElement("div", getLineProps({ }, tokens.map((line, i) => /*#__PURE__*/React.createElement("div", getLineProps({
line, line,
key: i key: i
}), line.map((token, key) => React.createElement("span", getTokenProps({ }), line.map((token, key) => /*#__PURE__*/React.createElement("span", getTokenProps({
token, token,
key key
}))))))); })))))));
} else { } else {
return React.createElement("div", null); return /*#__PURE__*/React.createElement("div", null);
} }
}); });
} }

View File

@ -32,6 +32,7 @@
.syntaxSwitch option { .syntaxSwitch option {
color: var(--color-primary-text); color: var(--color-primary-text);
font-weight:normal; font-weight:normal;
background-color: var(--ifm-navbar-background-color);
} }

View File

@ -26,7 +26,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]"} ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -39,7 +39,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]"} ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -1117,7 +1117,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#702 = #P in let p = rhs#702.0 in let s = rhs#702.1 in ( LIST_EMPTY() : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#702 = #P in\n let p = rhs#702.0 in\n let s = rhs#702.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -1130,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#705 = #P in let p = rhs#705.0 in let s = rhs#705.1 in ( LIST_EMPTY() : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can

View File

@ -158,7 +158,9 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes] ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address ,
owner -> address ,
profile -> bytes]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
do one of the following: do one of the following:

View File

@ -823,7 +823,7 @@ example, in verbose style:
type store is type store is
record record
goal : mutez; // Millionth of a tez goal : tez;
deadline : timestamp; deadline : timestamp;
backers : map (address, nat); backers : map (address, nat);
funded : bool funded : bool

View File

@ -303,12 +303,12 @@ and eval : Ast_typed.expression -> env -> value result
ok (label,v')) ok (label,v'))
(LMap.to_kv_list recmap) in (LMap.to_kv_list recmap) in
ok @@ V_Record (LMap.of_list lv') ok @@ V_Record (LMap.of_list lv')
| E_record_accessor { record ; label} -> ( | E_record_accessor { record ; path} -> (
let%bind record' = eval record env in let%bind record' = eval record env in
match record' with match record' with
| V_Record recmap -> | V_Record recmap ->
let%bind a = trace_option (simple_error "unknown record field") @@ let%bind a = trace_option (simple_error "unknown record field") @@
LMap.find_opt label recmap in LMap.find_opt path recmap in
ok a ok a
| _ -> simple_fail "trying to access a non-record" | _ -> simple_fail "trying to access a non-record"
) )

View File

@ -172,7 +172,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
aux node in aux node in
ok @@ snd m' ok @@ snd m'
| T_record m -> | T_record m ->
let node = Append_tree.of_list @@ kv_list_of_lmap m in let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in
let aux a b : type_value annotated result = let aux a b : type_value annotated result =
let%bind a = a in let%bind a = a in
let%bind b = b in let%bind b = b in
@ -191,7 +191,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
) )
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind -> let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = kv_list_of_lmap tym in let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in
let node_tv = Append_tree.of_list tys in let node_tv = Append_tree.of_list tys in
let%bind path = let%bind path =
let aux (i , _) = i = ind in let aux (i , _) = i = ind in
@ -290,7 +290,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return ~tv ae return ~tv ae
) )
| E_record m -> ( | E_record m -> (
let node = Append_tree.of_list @@ list_of_lmap m in (*list_of_lmap to record_to_list*)
let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in
let aux a b : expression result = let aux a b : expression result =
let%bind a = a in let%bind a = a in
let%bind b = b in let%bind b = b in
@ -302,16 +303,15 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
trace_strong (corner_case ~loc:__LOC__ "record build") @@ trace_strong (corner_case ~loc:__LOC__ "record build") @@
Append_tree.fold_ne (transpile_annotated_expression) aux node Append_tree.fold_ne (transpile_annotated_expression) aux node
) )
| E_record_accessor {record; label} -> | E_record_accessor {record; path} ->
let ty = get_type_expression record in let%bind ty' = transpile_type (get_type_expression record) in
let%bind ty' = transpile_type ty in
let%bind ty_lmap = let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@ trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record ty in get_t_record (get_type_expression record) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path = let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@ trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap label in record_access_to_lr ty' ty'_lmap path in
let aux = fun pred (ty, lr) -> let aux = fun pred (ty, lr) ->
let c = match lr with let c = match lr with
| `Left -> C_CAR | `Left -> C_CAR

View File

@ -232,7 +232,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind sub = untranspile v tv in let%bind sub = untranspile v tv in
return (E_constructor {constructor=Constructor name;element=sub}) return (E_constructor {constructor=Constructor name;element=sub})
| T_record m -> | T_record m ->
let lst = kv_list_of_lmap m in let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in
let%bind node = match Append_tree.of_list lst with let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in | Full t -> ok t in

View File

@ -5,9 +5,9 @@ module Errors = struct
let bad_self_address cst () = let bad_self_address cst () =
let title = thunk @@ let title = thunk @@
Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in
let message = thunk @@ let message = thunk @@
Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
error title message () error title message ()
end end
@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result =
| E_closure {binder=_ ; body} -> | E_closure {binder=_ ; body} ->
let%bind _self_in_lambdas = Helpers.map_expression let%bind _self_in_lambdas = Helpers.map_expression
(fun e -> match e.content with (fun e -> match e.content with
| E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c) | E_constant {cons_name=C_SELF_ADDRESS; _} -> fail (bad_self_address C_SELF_ADDRESS)
| _ -> ok e) | _ -> ok e)
body in body in
ok e ok e

View File

@ -225,7 +225,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x))[x := L(unit)] = (x)[x := L(unit)] =
L(unit) |}] ; L(unit) |}] ;
(* other var *) (* other var *)
@ -235,8 +235,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(y))[x := L(unit)] = (y)[x := L(unit)] =
V(y) y
|}] ; |}] ;
(* closure shadowed *) (* closure shadowed *)
@ -246,8 +246,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(C(fun x -> (V(x))))[x := L(unit)] = (fun x -> (x))[x := L(unit)] =
C(fun x -> (V(x))) fun x -> (x)
|}] ; |}] ;
(* closure not shadowed *) (* closure not shadowed *)
@ -257,8 +257,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(C(fun y -> (V(x))))[x := L(unit)] = (fun y -> (x))[x := L(unit)] =
C(fun y -> (L(unit))) fun y -> (L(unit))
|}] ; |}] ;
(* closure capture-avoidance *) (* closure capture-avoidance *)
@ -268,8 +268,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(wrap (E_variable y)) ; ~expr:(wrap (E_variable y)) ;
[%expect{| [%expect{|
(C(fun y -> ((V(x))@(V(y)))))[x := V(y)] = (fun y -> ((x)@(y)))[x := y] =
C(fun y#1 -> ((V(y))@(V(y#1)))) fun y#1 -> ((y)@(y#1))
|}] ; |}] ;
(* let-in shadowed (not in rhs) *) (* let-in shadowed (not in rhs) *)
@ -279,8 +279,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(let x = V(x) in ( V(x) ))[x := L(unit)] = (let x = x in x)[x := L(unit)] =
let x = L(unit) in ( V(x) ) let x = L(unit) in x
|}] ; |}] ;
(* let-in not shadowed *) (* let-in not shadowed *)
@ -290,8 +290,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(let y = V(x) in ( V(x) ))[x := L(unit)] = (let y = x in x)[x := L(unit)] =
let y = L(unit) in ( L(unit) ) let y = L(unit) in L(unit)
|}] ; |}] ;
(* let-in capture avoidance *) (* let-in capture avoidance *)
@ -302,8 +302,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] = (let y = x in (x)@(y))[x := y] =
let y#1 = V(y) in ( (V(y))@(V(y#1)) ) let y#1 = y in (y)@(y#1)
|}] ; |}] ;
(* iter shadowed *) (* iter shadowed *)
@ -313,8 +313,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(for_ITER x of V(x) do ( V(x) ))[x := L(unit)] = (for_ITER x of x do ( x ))[x := L(unit)] =
for_ITER x of L(unit) do ( V(x) ) for_ITER x of L(unit) do ( x )
|}] ; |}] ;
(* iter not shadowed *) (* iter not shadowed *)
@ -324,7 +324,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(for_ITER y of V(x) do ( V(x) ))[x := L(unit)] = (for_ITER y of x do ( x ))[x := L(unit)] =
for_ITER y of L(unit) do ( L(unit) ) for_ITER y of L(unit) do ( L(unit) )
|}] ; |}] ;
@ -335,8 +335,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] = (for_ITER y of (x)@(y) do ( (x)@(y) ))[x := y] =
for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) ) for_ITER y#1 of (y)@(y) do ( (y)@(y#1) )
|}] ; |}] ;
(* if_cons shadowed 1 *) (* if_cons shadowed 1 *)
@ -349,8 +349,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] = (x ?? x : (x :: y) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (x :: y) -> V(x) L(unit) ?? L(unit) : (x :: y) -> x
|}] ; |}] ;
(* if_cons shadowed 2 *) (* if_cons shadowed 2 *)
@ -363,8 +363,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] = (x ?? x : (y :: x) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: x) -> V(x) L(unit) ?? L(unit) : (y :: x) -> x
|}] ; |}] ;
(* if_cons not shadowed *) (* if_cons not shadowed *)
@ -377,7 +377,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] = (x ?? x : (y :: z) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: z) -> L(unit) L(unit) ?? L(unit) : (y :: z) -> L(unit)
|}] ; |}] ;
@ -391,8 +391,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] = (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := y] =
V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z))) y ?? y : (y#1 :: z) -> (y)@((y#1)@(z))
|}] ; |}] ;
(* if_cons capture avoidance 2 *) (* if_cons capture avoidance 2 *)
@ -405,8 +405,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var z) ; ~expr:(var z) ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] = (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := z] =
V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1))) z ?? z : (y :: z#1) -> (z)@((y)@(z#1))
|}] ; |}] ;
(* old bug *) (* old bug *)
@ -417,6 +417,6 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] = (fun y -> (fun y#1 -> ((x)@((y)@(y#1)))))[x := y] =
C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1))))))) fun y#2 -> (fun y#1 -> ((y)@((y#2)@(y#1))))
|}] ; |}] ;

View File

@ -11,7 +11,7 @@ end
open Errors open Errors
let peephole_type_expression : type_expression -> type_expression result = fun e -> let peephole_type_expression : type_expression -> type_expression result = fun e ->
let return type_content = ok { e with type_content } in let return type_content = ok {type_content } in
match e.type_content with match e.type_content with
| T_sum cmap -> | T_sum cmap ->
let%bind _uu = bind_map_cmapi let%bind _uu = bind_map_cmapi

View File

@ -51,6 +51,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self init' record in let%bind res = self init' record in
ok res ok res
) )
| E_tuple t -> (
let aux init'' expr =
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_list aux (init') t in
ok res
)
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
| E_let_in { let_binder = _ ; rhs ; let_result } -> ( | E_let_in { let_binder = _ ; rhs ; let_result } -> (
let%bind res = self init' rhs in let%bind res = self init' rhs in
let%bind res = self res let_result in let%bind res = self res let_result in
@ -59,6 +76,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
| E_recursive { lambda={result=e;_}; _} -> | E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in let%bind res = self init' e in
ok res ok res
| E_cond {condition; then_clause; else_clause} ->
let%bind res = self init' condition in
let%bind res = self res then_clause in
let%bind res = self res else_clause in
ok res
| E_sequence {expr1;expr2} -> | E_sequence {expr1;expr2} ->
let ab = (expr1,expr2) in let ab = (expr1,expr2) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
@ -161,6 +183,19 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind update = self update in let%bind update = self update in
return @@ E_record_update {record;path;update} return @@ E_record_update {record;path;update}
) )
| E_tuple t -> (
let%bind t' = bind_map_list self t in
return @@ E_tuple t'
)
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_constructor c -> ( | E_constructor c -> (
let%bind e' = self c.element in let%bind e' = self c.element in
return @@ E_constructor {c with element = e'} return @@ E_constructor {c with element = e'}
@ -187,6 +222,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind args = bind_map_list self c.arguments in let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args} return @@ E_constant {c with arguments=args}
) )
| E_cond {condition; then_clause; else_clause} ->
let%bind condition = self condition in
let%bind then_clause = self then_clause in
let%bind else_clause = self else_clause in
return @@ E_cond {condition;then_clause;else_clause}
| E_sequence {expr1;expr2} -> ( | E_sequence {expr1;expr2} -> (
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
return @@ E_sequence {expr1;expr2} return @@ E_sequence {expr1;expr2}
@ -212,7 +252,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
let self = map_type_expression f in let self = map_type_expression f in
let%bind te' = f te in let%bind te' = f te in
let return type_content = ok { te' with type_content } in let return type_content = ok { type_content } in
match te'.type_content with match te'.type_content with
| T_sum temap -> | T_sum temap ->
let%bind temap' = bind_map_cmap self temap in let%bind temap' = bind_map_cmap self temap in
@ -220,6 +260,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_record temap -> | T_record temap ->
let%bind temap' = bind_map_lmap self temap in let%bind temap' = bind_map_lmap self temap in
return @@ (T_record temap') return @@ (T_record temap')
| T_tuple telst ->
let%bind telst' = bind_map_list self telst in
return @@ (T_tuple telst')
| T_arrow {type1 ; type2} -> | T_arrow {type1 ; type2} ->
let%bind type1' = self type1 in let%bind type1' = self type1 in
let%bind type2' = self type2 in let%bind type2' = self type2 in
@ -324,6 +367,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res, update) = self res update in let%bind (res, update) = self res update in
ok (res, return @@ E_record_update {record;path;update}) ok (res, return @@ E_record_update {record;path;update})
) )
| E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t')
)
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> ( | E_constructor c -> (
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})
@ -350,6 +406,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,args) = bind_fold_map_list self init' c.arguments in let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args}) ok (res, return @@ E_constant {c with arguments=args})
) )
| E_cond {condition; then_clause; else_clause} ->
let%bind res,condition = self init' condition in
let%bind res,then_clause = self res then_clause in
let%bind res,else_clause = self res else_clause in
ok (res, return @@ E_cond {condition;then_clause;else_clause})
| E_sequence {expr1;expr2} -> ( | E_sequence {expr1;expr2} -> (
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
ok (res, return @@ E_sequence {expr1;expr2}) ok (res, return @@ E_sequence {expr1;expr2})

View File

@ -123,6 +123,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result
) record ) record
in in
return @@ O.T_record (O.LMap.of_list record) return @@ O.T_record (O.LMap.of_list record)
| I.T_tuple tuple ->
let%bind tuple = bind_map_list compile_type_expression tuple in
return @@ O.T_tuple tuple
| I.T_arrow {type1;type2} -> | I.T_arrow {type1;type2} ->
let%bind type1 = compile_type_expression type1 in let%bind type1 = compile_type_expression type1 in
let%bind type2 = compile_type_expression type2 in let%bind type2 = compile_type_expression type2 in
@ -154,9 +157,6 @@ and compile_type_operator : I.type_operator -> O.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_big_map (k,v) ok @@ O.TC_big_map (k,v)
| TC_map_or_big_map (k,v) ->
let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in
ok @@ O.TC_map_or_big_map (k,v)
| TC_arrow (i,o) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) ok @@ O.TC_arrow (i,o)
@ -202,9 +202,9 @@ let rec compile_expression : I.expression -> O.expression result =
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {record;label} -> | I.E_record_accessor {record;path} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;label} return @@ O.E_record_accessor {record;path}
| I.E_record_update {record;path;update} -> | I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
let%bind update = compile_expression update in let%bind update = compile_expression update in
@ -234,11 +234,43 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind anno_expr = compile_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = compile_type_expression type_annotation in let%bind type_annotation = compile_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation} return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_cond {condition;then_clause;else_clause} ->
let%bind condition = compile_expression condition in
let%bind then_clause' = compile_expression then_clause in
let%bind else_clause' = compile_expression else_clause in
let env = Var.fresh () in
let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in
let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in
let then_clause = add_to_end then_clause (O.e_variable env) in
let else_clause = add_to_end else_clause (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in
if (List.length free_vars != 0) then
let cond_expr = O.e_cond condition then_clause else_clause in
let return_expr = fun expr ->
O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars);
let_result=O.e_let_in (env,None) false false cond_expr @@
expr
}
in
return @@ restore_mutable_variable return_expr free_vars env
else
return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'}
| I.E_sequence {expr1; expr2} -> | I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in let%bind expr2 = compile_expression expr2 in
ok @@ add_to_end expr1 expr2 ok @@ add_to_end expr1 expr2
| I.E_skip -> return @@ O.E_skip | I.E_skip -> return @@ O.E_skip
| I.E_tuple tuple ->
let%bind tuple = bind_map_list compile_expression tuple in
return @@ O.E_tuple (tuple)
| I.E_tuple_accessor {tuple;path} ->
let%bind tuple = compile_expression tuple in
return @@ O.E_tuple_accessor {tuple;path}
| I.E_tuple_update {tuple;path;update} ->
let%bind tuple = compile_expression tuple in
let%bind update = compile_expression update in
return @@ O.E_tuple_update {tuple;path;update}
| I.E_assign ass -> | I.E_assign ass ->
let%bind content = compile_assign ass @@ O.e_skip () in let%bind content = compile_assign ass @@ O.e_skip () in
return @@ content return @@ content
@ -282,7 +314,6 @@ and compile_assign {variable; access_path; expression} expr =
let%bind rhs = rhs @@ expression in let%bind rhs = rhs @@ expression in
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false} ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false}
and compile_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
let%bind input_type = bind_map_option compile_type_expression input_type in let%bind input_type = bind_map_option compile_type_expression input_type in
@ -541,6 +572,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul
) record ) record
in in
return @@ I.T_record (O.LMap.of_list record) return @@ I.T_record (O.LMap.of_list record)
| O.T_tuple tuple ->
let%bind tuple = bind_map_list uncompile_type_expression tuple in
return @@ I.T_tuple tuple
| O.T_arrow {type1;type2} -> | O.T_arrow {type1;type2} ->
let%bind type1 = uncompile_type_expression type1 in let%bind type1 = uncompile_type_expression type1 in
let%bind type2 = uncompile_type_expression type2 in let%bind type2 = uncompile_type_expression type2 in
@ -572,9 +606,6 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v) ok @@ I.TC_big_map (k,v)
| TC_map_or_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map_or_big_map (k,v)
| TC_arrow (i,o) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o) ok @@ I.TC_arrow (i,o)
@ -621,13 +652,23 @@ let rec uncompile_expression : O.expression -> I.expression result =
) record ) record
in in
return @@ I.E_record (O.LMap.of_list record) return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;label} -> | O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;label} return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} -> | O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in let%bind update = uncompile_expression update in
return @@ I.E_record_update {record;path;update} return @@ I.E_record_update {record;path;update}
| O.E_tuple tuple ->
let%bind tuple = bind_map_list uncompile_expression tuple in
return @@ I.E_tuple tuple
| O.E_tuple_accessor {tuple;path} ->
let%bind tuple = uncompile_expression tuple in
return @@ I.E_tuple_accessor {tuple;path}
| O.E_tuple_update {tuple;path;update} ->
let%bind tuple = uncompile_expression tuple in
let%bind update = uncompile_expression update in
return @@ I.E_tuple_update {tuple;path;update}
| O.E_map map -> | O.E_map map ->
let%bind map = bind_map_list ( let%bind map = bind_map_list (
bind_map_pair uncompile_expression bind_map_pair uncompile_expression
@ -653,6 +694,11 @@ let rec uncompile_expression : O.expression -> I.expression result =
let%bind anno_expr = uncompile_expression anno_expr in let%bind anno_expr = uncompile_expression anno_expr in
let%bind type_annotation = uncompile_type_expression type_annotation in let%bind type_annotation = uncompile_type_expression type_annotation in
return @@ I.E_ascription {anno_expr; type_annotation} return @@ I.E_ascription {anno_expr; type_annotation}
| O.E_cond {condition;then_clause;else_clause} ->
let%bind condition = uncompile_expression condition in
let%bind then_clause = uncompile_expression then_clause in
let%bind else_clause = uncompile_expression else_clause in
return @@ I.E_cond {condition; then_clause; else_clause}
| O.E_sequence {expr1; expr2} -> | O.E_sequence {expr1; expr2} ->
let%bind expr1 = uncompile_expression expr1 in let%bind expr1 = uncompile_expression expr1 in
let%bind expr2 = uncompile_expression expr2 in let%bind expr2 = uncompile_expression expr2 in

View File

@ -56,6 +56,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let%bind res = self res let_result in let%bind res = self res let_result in
ok res ok res
) )
| E_cond {condition; then_clause; else_clause} ->
let%bind res = self init' condition in
let%bind res = self res then_clause in
let%bind res = self res else_clause in
ok res
| E_recursive { lambda={result=e;_}; _} -> | E_recursive { lambda={result=e;_}; _} ->
let%bind res = self init' e in let%bind res = self init' e in
ok res ok res
@ -63,6 +68,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
let ab = (expr1,expr2) in let ab = (expr1,expr2) in
let%bind res = bind_fold_pair self init' ab in let%bind res = bind_fold_pair self init' ab in
ok res ok res
| E_tuple t -> (
let aux init'' expr =
let%bind res = fold_expression self init'' expr in
ok res
in
let%bind res = bind_fold_list aux (init') t in
ok res
)
| E_tuple_update {tuple;update} -> (
let%bind res = self init' tuple in
let%bind res = fold_expression self res update in
ok res
)
| E_tuple_accessor {tuple} -> (
let%bind res = self init' tuple in
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
@ -172,16 +194,34 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
let%bind args = bind_map_list self c.arguments in let%bind args = bind_map_list self c.arguments in
return @@ E_constant {c with arguments=args} return @@ E_constant {c with arguments=args}
) )
| E_cond {condition; then_clause; else_clause} ->
let%bind condition = self condition in
let%bind then_clause = self then_clause in
let%bind else_clause = self else_clause in
return @@ E_cond {condition;then_clause;else_clause}
| E_sequence {expr1;expr2} -> ( | E_sequence {expr1;expr2} -> (
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
return @@ E_sequence {expr1;expr2} return @@ E_sequence {expr1;expr2}
) )
| E_tuple t -> (
let%bind t' = bind_map_list self t in
return @@ E_tuple t'
)
| E_tuple_update {tuple; path; update} -> (
let%bind tuple = self tuple in
let%bind update = self update in
return @@ E_tuple_update {tuple; path; update}
)
| E_tuple_accessor {tuple;path} -> (
let%bind tuple = self tuple in
return @@ E_tuple_accessor {tuple;path}
)
| E_literal _ | E_variable _ | E_skip as e' -> return e' | E_literal _ | E_variable _ | E_skip as e' -> return e'
and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te ->
let self = map_type_expression f in let self = map_type_expression f in
let%bind te' = f te in let%bind te' = f te in
let return type_content = ok { te' with type_content } in let return type_content = ok { type_content } in
match te'.type_content with match te'.type_content with
| T_sum temap -> | T_sum temap ->
let%bind temap' = bind_map_cmap self temap in let%bind temap' = bind_map_cmap self temap in
@ -189,6 +229,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re
| T_record temap -> | T_record temap ->
let%bind temap' = bind_map_lmap self temap in let%bind temap' = bind_map_lmap self temap in
return @@ (T_record temap') return @@ (T_record temap')
| T_tuple telst ->
let%bind telst' = bind_map_list self telst in
return @@ (T_tuple telst')
| T_arrow {type1 ; type2} -> | T_arrow {type1 ; type2} ->
let%bind type1' = self type1 in let%bind type1' = self type1 in
let%bind type2' = self type2 in let%bind type2' = self type2 in
@ -293,6 +336,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res, update) = self res update in let%bind (res, update) = self res update in
ok (res, return @@ E_record_update {record;path;update}) ok (res, return @@ E_record_update {record;path;update})
) )
| E_tuple t -> (
let%bind (res, t') = bind_fold_map_list self init' t in
ok (res, return @@ E_tuple t')
)
| E_tuple_update {tuple; path; update} -> (
let%bind (res, tuple) = self init' tuple in
let%bind (res, update) = self res update in
ok (res, return @@ E_tuple_update {tuple;path;update})
)
| E_tuple_accessor {tuple; path} -> (
let%bind (res, tuple) = self init' tuple in
ok (res, return @@ E_tuple_accessor {tuple; path})
)
| E_constructor c -> ( | E_constructor c -> (
let%bind (res,e') = self init' c.element in let%bind (res,e') = self init' c.element in
ok (res, return @@ E_constructor {c with element = e'}) ok (res, return @@ E_constructor {c with element = e'})
@ -319,6 +375,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,args) = bind_fold_map_list self init' c.arguments in let%bind (res,args) = bind_fold_map_list self init' c.arguments in
ok (res, return @@ E_constant {c with arguments=args}) ok (res, return @@ E_constant {c with arguments=args})
) )
| E_cond {condition; then_clause; else_clause} ->
let%bind res,condition = self init' condition in
let%bind res,then_clause = self res then_clause in
let%bind res,else_clause = self res else_clause in
ok (res, return @@ E_cond {condition;then_clause;else_clause})
| E_sequence {expr1;expr2} -> ( | E_sequence {expr1;expr2} -> (
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
ok (res, return @@ E_sequence {expr1;expr2}) ok (res, return @@ E_sequence {expr1;expr2})

View File

@ -24,6 +24,13 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result =
) record ) record
in in
return @@ O.T_record (O.LMap.of_list record) return @@ O.T_record (O.LMap.of_list record)
| I.T_tuple tuple ->
let aux (i,acc) el =
let%bind el = idle_type_expression el in
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in
let record = O.LMap.of_list lst in
return @@ O.T_record record
| I.T_arrow {type1;type2} -> | I.T_arrow {type1;type2} ->
let%bind type1 = idle_type_expression type1 in let%bind type1 = idle_type_expression type1 in
let%bind type2 = idle_type_expression type2 in let%bind type2 = idle_type_expression type2 in
@ -55,9 +62,6 @@ and idle_type_operator : I.type_operator -> O.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_big_map (k,v) ok @@ O.TC_big_map (k,v)
| TC_map_or_big_map (k,v) ->
let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in
ok @@ O.TC_map_or_big_map (k,v)
| TC_arrow (i,o) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in
ok @@ O.TC_arrow (i,o) ok @@ O.TC_arrow (i,o)
@ -104,9 +108,9 @@ let rec compile_expression : I.expression -> O.expression result =
) record ) record
in in
return @@ O.E_record (O.LMap.of_list record) return @@ O.E_record (O.LMap.of_list record)
| I.E_record_accessor {record;label} -> | I.E_record_accessor {record;path} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
return @@ O.E_record_accessor {record;label} return @@ O.E_record_accessor {record;path}
| I.E_record_update {record;path;update} -> | I.E_record_update {record;path;update} ->
let%bind record = compile_expression record in let%bind record = compile_expression record in
let%bind update = compile_expression update in let%bind update = compile_expression update in
@ -150,11 +154,32 @@ let rec compile_expression : I.expression -> O.expression result =
let%bind anno_expr = compile_expression anno_expr in let%bind anno_expr = compile_expression anno_expr in
let%bind type_annotation = idle_type_expression type_annotation in let%bind type_annotation = idle_type_expression type_annotation in
return @@ O.E_ascription {anno_expr; type_annotation} return @@ O.E_ascription {anno_expr; type_annotation}
| I.E_cond {condition; then_clause; else_clause} ->
let%bind matchee = compile_expression condition in
let%bind match_true = compile_expression then_clause in
let%bind match_false = compile_expression else_clause in
return @@ O.E_matching {matchee; cases=Match_bool{match_true;match_false}}
| I.E_sequence {expr1; expr2} -> | I.E_sequence {expr1; expr2} ->
let%bind expr1 = compile_expression expr1 in let%bind expr1 = compile_expression expr1 in
let%bind expr2 = compile_expression expr2 in let%bind expr2 = compile_expression expr2 in
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false} return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false}
| I.E_skip -> ok @@ O.e_unit ~loc:e.location () | I.E_skip -> ok @@ O.e_unit ~loc:e.location ()
| I.E_tuple t ->
let aux (i,acc) el =
let%bind el = compile_expression el in
ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in
let%bind (_, lst ) = bind_fold_list aux (0,[]) t in
let m = O.LMap.of_list lst in
return @@ O.E_record m
| I.E_tuple_accessor {tuple;path} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
return @@ O.E_record_accessor {record;path}
| I.E_tuple_update {tuple;path;update} ->
let%bind record = compile_expression tuple in
let path = O.Label (string_of_int path) in
let%bind update = compile_expression update in
return @@ O.E_record_update {record;path;update}
and compile_lambda : I.lambda -> O.lambda result = and compile_lambda : I.lambda -> O.lambda result =
fun {binder;input_type;output_type;result}-> fun {binder;input_type;output_type;result}->
@ -261,9 +286,7 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result =
| TC_big_map (k,v) -> | TC_big_map (k,v) ->
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_big_map (k,v) ok @@ I.TC_big_map (k,v)
| TC_map_or_big_map (k,v) -> | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled"
let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in
ok @@ I.TC_map_or_big_map (k,v)
| TC_arrow (i,o) -> | TC_arrow (i,o) ->
let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in
ok @@ I.TC_arrow (i,o) ok @@ I.TC_arrow (i,o)
@ -314,9 +337,9 @@ let rec uncompile_expression : O.expression -> I.expression result =
) record ) record
in in
return @@ I.E_record (O.LMap.of_list record) return @@ I.E_record (O.LMap.of_list record)
| O.E_record_accessor {record;label} -> | O.E_record_accessor {record;path} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
return @@ I.E_record_accessor {record;label} return @@ I.E_record_accessor {record;path}
| O.E_record_update {record;path;update} -> | O.E_record_update {record;path;update} ->
let%bind record = uncompile_expression record in let%bind record = uncompile_expression record in
let%bind update = uncompile_expression update in let%bind update = uncompile_expression update in

View File

@ -455,10 +455,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
* | _ -> return (E_literal (Literal_string s)) (t_string ()) * | _ -> return (E_literal (Literal_string s)) (t_string ())
* ) *) * ) *)
| E_record_accessor {record;label} -> ( | E_record_accessor {record;path} -> (
let%bind (base' , state') = type_expression e state record in let%bind (base' , state') = type_expression e state record in
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in
return_wrapped (E_record_accessor {record=base';label}) state' wrapped return_wrapped (E_record_accessor {record=base';path}) state' wrapped
) )
(* Sum *) (* Sum *)
@ -917,15 +917,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind r' = bind_smap let%bind r' = bind_smap
@@ Map.String.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor {record; label} -> | E_record_accessor {record; path} ->
let%bind r' = untype_expression record in let%bind r' = untype_expression record in
let Label s = label in let Label s = path in
return (e_accessor r' s) return (e_record_accessor r' s)
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
let%bind r' = untype_expression record in let%bind r' = untype_expression record in
let%bind e = untype_expression update in let%bind e = untype_expression update in
let Label l = path in let Label l = path in
return (e_update r' l e) return (e_record_update r' l e)
| E_matching {matchee;cases} -> | E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in let%bind m' = untype_matching untype_expression cases in

View File

@ -454,7 +454,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
return (e_address s) (t_address ()) return (e_address s) (t_address ())
| E_literal (Literal_operation op) -> | E_literal (Literal_operation op) ->
return (e_operation op) (t_operation ()) return (e_operation op) (t_operation ())
| E_record_accessor {record;label} -> | E_record_accessor {record;path} ->
let%bind e' = type_expression' e record in let%bind e' = type_expression' e record in
let aux (prev:O.expression) (a:I.label) : O.expression result = let aux (prev:O.expression) (a:I.label) : O.expression result =
let property = a in let property = a in
@ -463,10 +463,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
generic_try (bad_record_access property ae prev.type_expression ae.location) generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> I.LMap.find property r_tv) in @@ (fun () -> I.LMap.find property r_tv) in
let location = ae.location in let location = ae.location in
ok @@ make_a_e ~location (E_record_accessor {record=prev; label=property}) tv e ok @@ make_a_e ~location (E_record_accessor {record=prev; path=property}) tv e
in in
let%bind ae = let%bind ae =
trace (simple_info "accessing") @@ aux e' label in trace (simple_info "accessing") @@ aux e' path in
(* check type annotation of the final accessed element *) (* check type annotation of the final accessed element *)
let%bind () = let%bind () =
match tv_opt with match tv_opt with
@ -787,15 +787,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let%bind r' = bind_smap let%bind r' = bind_smap
@@ Map.String.map untype_expression r in @@ Map.String.map untype_expression r in
return (e_record r') return (e_record r')
| E_record_accessor {record; label} -> | E_record_accessor {record; path} ->
let%bind r' = untype_expression record in let%bind r' = untype_expression record in
let Label s = label in let Label s = path in
return (e_accessor r' s) return (e_record_accessor r' s)
| E_record_update {record=r; path=l; update=e} -> | E_record_update {record=r; path=l; update=e} ->
let%bind r' = untype_expression r in let%bind r' = untype_expression r in
let%bind e = untype_expression e in let%bind e = untype_expression e in
let Label l = l in let Label l = l in
return (e_update r' l e) return (e_record_update r' l e)
| E_matching {matchee;cases} -> | E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in let%bind m' = untype_matching untype_expression cases in

View File

@ -91,9 +91,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
let%bind cases' = map_cases f cases in let%bind cases' = map_cases f cases in
return @@ E_matching {matchee=e';cases=cases'} return @@ E_matching {matchee=e';cases=cases'}
) )
| E_record_accessor acc -> ( | E_record_accessor {record; path} -> (
let%bind e' = self acc.record in let%bind record = self record in
return @@ E_record_accessor {acc with record = e'} return @@ E_record_accessor {record; path}
) )
| E_record m -> ( | E_record m -> (
let%bind m' = bind_map_lmap self m in let%bind m' = bind_map_lmap self m in
@ -186,9 +186,9 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
let%bind (res,cases') = fold_map_cases f res cases in let%bind (res,cases') = fold_map_cases f res cases in
ok (res, return @@ E_matching {matchee=e';cases=cases'}) ok (res, return @@ E_matching {matchee=e';cases=cases'})
) )
| E_record_accessor acc -> ( | E_record_accessor {record; path} -> (
let%bind (res, e') = self init' acc.record in let%bind (res, record) = self init' record in
ok (res, return @@ E_record_accessor {acc with record = e'}) ok (res, return @@ E_record_accessor {record; path})
) )
| E_record m -> ( | E_record m -> (
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in

View File

@ -4,11 +4,45 @@ open Format
open PP_helpers open PP_helpers
include Stage_common.PP include Stage_common.PP
include Ast_PP_type(Ast_imperative_parameter)
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> type_expression
-> unit =
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
let rec expression ppf (e : expression) = let rec expression ppf (e : expression) =
expression_content ppf e.expression_content expression_content ppf e.expression_content
@ -26,11 +60,11 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor {record; label=l}-> | E_record_accessor ra ->
fprintf ppf "%a.%a" expression record label l fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update fprintf ppf "{ %a with %a = %a }" expression record label path expression update
| E_map m -> | E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> | E_big_map m ->
@ -62,10 +96,21 @@ and expression_content ppf (ec : expression_content) =
| E_ascription {anno_expr; type_annotation} -> | E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation type_annotation
| E_cond {condition; then_clause; else_clause} ->
fprintf ppf "if %a then %a else %a"
expression condition
expression then_clause
expression else_clause
| E_sequence {expr1;expr2} -> | E_sequence {expr1;expr2} ->
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
| E_skip -> | E_skip ->
fprintf ppf "skip" fprintf ppf "skip"
| E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path
| E_tuple_update {tuple; path; update} ->
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
| E_assign {variable; access_path; expression=e} -> | E_assign {variable; access_path; expression=e} ->
fprintf ppf "%a%a := %a" fprintf ppf "%a%a := %a"
expression_variable variable expression_variable variable

View File

@ -19,14 +19,9 @@ module Errors = struct
end end
open Errors open Errors
let make_t type_content = {type_content; type_meta = ()} let make_t type_content = {type_content}
let tuple_to_record lst =
let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in
let (_, lst ) = List.fold_left aux (0,[]) lst in
lst
let t_bool : type_expression = make_t @@ T_constant (TC_bool) let t_bool : type_expression = make_t @@ T_constant (TC_bool)
let t_string : type_expression = make_t @@ T_constant (TC_string) let t_string : type_expression = make_t @@ T_constant (TC_string)
let t_bytes : type_expression = make_t @@ T_constant (TC_bytes) let t_bytes : type_expression = make_t @@ T_constant (TC_bytes)
@ -51,8 +46,8 @@ let t_record m : type_expression =
let lst = Map.String.to_kv_list m in let lst = Map.String.to_kv_list m in
t_record_ez lst t_record_ez lst
let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)] let t_tuple lst : type_expression = make_t @@ T_tuple lst
let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst) let t_pair (a , b) : type_expression = t_tuple [a; b]
let ez_t_sum (lst:(string * type_expression) list) : type_expression = let ez_t_sum (lst:(string * type_expression) list) : type_expression =
let aux prev (k, v) = CMap.add (Constructor k) v prev in let aux prev (k, v) = CMap.add (Constructor k) v prev in
@ -118,7 +113,8 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
let e_accessor ?loc a b = e_record_accessor ?loc a b
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_skip ?loc () = make_expr ?loc @@ E_skip let e_skip ?loc () = make_expr ?loc @@ E_skip
@ -135,7 +131,7 @@ let e_while ?loc condition body = make_expr ?loc @@ E_while {condition; body}
let e_for ?loc binder start final increment body = make_expr ?loc @@ E_for {binder;start;final;increment;body} let e_for ?loc binder start final increment body = make_expr ?loc @@ E_for {binder;start;final;increment;body}
let e_for_each ?loc binder collection collection_type body = make_expr ?loc @@ E_for_each {binder;collection;collection_type;body} let e_for_each ?loc binder collection collection_type body = make_expr ?loc @@ E_for_each {binder;collection;collection_type;body}
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause}
(* (*
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
*) *)
@ -151,11 +147,12 @@ let e_record ?loc map =
let lst = Map.String.to_kv_list map in let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst e_record_ez ?loc lst
let e_update ?loc record path update = let e_record_update ?loc record path update =
let path = Label path in let path = Label path in
make_expr ?loc @@ E_record_update {record; path; update} make_expr ?loc @@ E_record_update {record; path; update}
let e_update ?loc record path update = e_record_update ?loc record path update
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) let e_tuple ?loc lst : expression = make_expr ?loc @@ E_tuple lst
let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
let make_option_typed ?loc e t_opt = let make_option_typed ?loc e t_opt =
@ -201,7 +198,7 @@ let e_ez_assign ?loc variable access_path expression =
let get_e_accessor = fun t -> let get_e_accessor = fun t ->
match t with match t with
| E_record_accessor {record; label} -> ok (record , label) | E_record_accessor {record; path} -> ok (record , path)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t -> let assert_e_accessor = fun t ->
@ -210,14 +207,7 @@ let assert_e_accessor = fun t ->
let get_e_pair = fun t -> let get_e_pair = fun t ->
match t with match t with
| E_record r -> ( | E_tuple [a ; b] -> ok (a , b)
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| _ -> simple_fail "not a pair" | _ -> simple_fail "not a pair"
let get_e_list = fun t -> let get_e_list = fun t ->
@ -225,29 +215,15 @@ let get_e_list = fun t ->
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> simple_fail "not a list" | _ -> simple_fail "not a list"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_e_tuple = fun t -> let get_e_tuple = fun t ->
match t with match t with
| E_record r -> ok @@ tuple_of_record r | E_tuple t -> ok @@ t
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple" | _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *) (* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e -> let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression_content with match e.expression_content with
| E_record r -> ( | E_tuple [a;b] -> ok @@ (a,b)
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| _ -> fail @@ bad_kind "pair" e.location | _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e -> let extract_list : expression -> (expression list) result = fun e ->

View File

@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_record_update _, _ -> | E_record_update _, _ ->
simple_fail "comparing record update with other expression" simple_fail "comparing record update with other expression"
| E_tuple lsta, E_tuple lstb -> (
let%bind lst =
generic_try (simple_error "tuples with different number of elements")
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
| E_tuple _, _ ->
simple_fail "comparing tuple with other expression"
| E_tuple_update uta, E_tuple_update utb ->
let _ =
generic_try (simple_error "Updating different tuple") @@
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
let () = assert (uta.path == utb.path) in
let%bind () = assert_value_eq (uta.update,utb.update) in
ok ()
| E_tuple_update _, _ ->
simple_fail "comparing tuple update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (simple_error "maps of different lengths") let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () -> (fun () ->
@ -182,8 +202,10 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _) | (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _) | (E_recursive _,_)
| (E_look_up _, _) | (E_matching _, _) | (E_record_accessor _, _) | (E_tuple_accessor _, _)
| (E_look_up _, _)
| (E_matching _, _) | (E_cond _, _)
| (E_sequence _, _) | (E_skip, _) | (E_sequence _, _) | (E_skip, _)
| (E_assign _, _) | (E_assign _, _)
| (E_for _, _) | (E_for_each _, _) | (E_for _, _) | (E_for_each _, _)

View File

@ -2,17 +2,31 @@
module Location = Simple_utils.Location module Location = Simple_utils.Location
module Ast_imperative_parameter = struct
type type_meta = unit
end
include Stage_common.Types include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter) type type_content =
*) | T_sum of type_expression constructor_map
include Ast_generic_type (Ast_imperative_parameter) | T_record of type_expression label_map
| T_tuple of type_expression list
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
and arrow = {type1: type_expression; type2: type_expression}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content}
type inline = bool
type program = declaration Location.wrap list type program = declaration Location.wrap list
and declaration = and declaration =
| Declaration_type of (type_variable * type_expression) | Declaration_type of (type_variable * type_expression)
@ -22,7 +36,7 @@ and declaration =
* an optional type annotation * an optional type annotation
* a boolean indicating whether it should be inlined * a boolean indicating whether it should be inlined
* an expression *) * an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression) | Declaration_constant of (expression_variable * type_expression option * bool * expression)
(* | Macro_declaration of macro_declaration *) (* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t} and expression = {expression_content: expression_content; location: Location.t}
@ -41,13 +55,17 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of accessor | E_record_accessor of record_accessor
| E_record_update of update | E_record_update of record_update
(* Advanced *) (* Advanced *)
| E_ascription of ascription | E_ascription of ascription
(* Sugar *) (* Sugar *)
| E_cond of conditional
| E_sequence of sequence | E_sequence of sequence
| E_skip | E_skip
| E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *) (* Data Structures *)
| E_map of (expression * expression) list | E_map of (expression * expression) list
| E_big_map of (expression * expression) list | E_big_map of (expression * expression) list
@ -89,9 +107,10 @@ and let_in =
and constructor = {constructor: constructor'; element: expression} and constructor = {constructor: constructor'; element: expression}
and accessor = {record: expression; label: label} and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content and matching_expr = (expr,unit) matching_content
and matching = and matching =
@ -100,11 +119,21 @@ and matching =
} }
and ascription = {anno_expr: expression; type_annotation: type_expression} and ascription = {anno_expr: expression; type_annotation: type_expression}
and conditional = {
condition : expression ;
then_clause : expression ;
else_clause : expression ;
}
and sequence = { and sequence = {
expr1: expression ; expr1: expression ;
expr2: expression ; expr2: expression ;
} }
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and assign = { and assign = {
variable : expression_variable; variable : expression_variable;
access_path : access list; access_path : access list;

View File

@ -4,11 +4,41 @@ open Format
open PP_helpers open PP_helpers
include Stage_common.PP include Stage_common.PP
include Ast_PP_type(Ast_sugar_parameter)
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> type_expression
-> unit =
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m
| T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
let rec expression ppf (e : expression) = let rec expression ppf (e : expression) =
expression_content ppf e.expression_content expression_content ppf e.expression_content
@ -26,11 +56,11 @@ and expression_content ppf (ec : expression_content) =
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression)
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m fprintf ppf "{%a}" (record_sep expression (const ";")) m
| E_record_accessor ra -> | E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.label fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update fprintf ppf "{ %a with %a = %a }" expression record label path expression update
| E_map m -> | E_map m ->
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
| E_big_map m -> | E_big_map m ->
@ -63,12 +93,23 @@ and expression_content ppf (ec : expression_content) =
expression rhs expression rhs
option_inline inline option_inline inline
expression let_result expression let_result
| E_sequence {expr1;expr2} ->
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
| E_ascription {anno_expr; type_annotation} -> | E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
| E_cond {condition; then_clause; else_clause} ->
fprintf ppf "if %a then %a else %a"
expression condition
expression then_clause
expression else_clause
| E_sequence {expr1;expr2} ->
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
| E_skip -> | E_skip ->
fprintf ppf "skip" fprintf ppf "skip"
| E_tuple t ->
fprintf ppf "(%a)" (list_sep_d expression) t
| E_tuple_accessor ta ->
fprintf ppf "%a.%d" expression ta.tuple ta.path
| E_tuple_update {tuple; path; update} ->
fprintf ppf "{ %a with %d = %a }" expression tuple path expression update
and option_type_name ppf and option_type_name ppf
((n, ty_opt) : expression_variable * type_expression option) = ((n, ty_opt) : expression_variable * type_expression option) =

View File

@ -19,7 +19,7 @@ module Errors = struct
end end
open Errors open Errors
let make_t type_content = {type_content; type_meta = ()} let make_t type_content = {type_content}
let tuple_to_record lst = let tuple_to_record lst =
@ -112,6 +112,8 @@ let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NO
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_let_in ?loc (binder, ascr) mut inline rhs let_result = let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
@ -120,6 +122,7 @@ let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; ar
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause}
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2}
let e_skip ?loc () = make_expr ?loc @@ E_skip let e_skip ?loc () = make_expr ?loc @@ E_skip
@ -127,6 +130,7 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
let e_look_up ?loc a b : expression = make_expr ?loc @@ E_look_up (a,b)
let ez_match_variant (lst : ((string * string) * 'a) list) = let ez_match_variant (lst : ((string * string) * 'a) list) =
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
@ -139,7 +143,7 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression =
let e_record ?loc map = let e_record ?loc map =
let lst = Map.String.to_kv_list map in let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst e_record_ez ?loc lst
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path= Label b}
let e_record_update ?loc record path update = let e_record_update ?loc record path update =
let path = Label path in let path = Label path in
@ -150,7 +154,6 @@ let make_option_typed ?loc e t_opt =
| None -> e | None -> e
| Some t -> e_annotation ?loc e t | Some t -> e_annotation ?loc e t
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
@ -180,25 +183,18 @@ let e_lambda ?loc (binder : expression_variable)
} }
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
let get_e_accessor = fun t -> let get_e_record_accessor = fun t ->
match t with match t with
| E_record_accessor {record; label} -> ok (record , label) | E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not a record accessor"
let assert_e_accessor = fun t -> let assert_e_accessor = fun t ->
let%bind _ = get_e_accessor t in let%bind _ = get_e_record_accessor t in
ok () ok ()
let get_e_pair = fun t -> let get_e_pair = fun t ->
match t with match t with
| E_record r -> ( | E_tuple [a ; b] -> ok (a , b)
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> simple_fail "not a pair"
)
| _ -> simple_fail "not a pair" | _ -> simple_fail "not a pair"
let get_e_list = fun t -> let get_e_list = fun t ->
@ -206,29 +202,15 @@ let get_e_list = fun t ->
| E_list lst -> ok lst | E_list lst -> ok lst
| _ -> simple_fail "not a list" | _ -> simple_fail "not a list"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_e_tuple = fun t -> let get_e_tuple = fun t ->
match t with match t with
| E_record r -> ok @@ tuple_of_record r | E_tuple t -> ok @@ t
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple" | _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *) (* Same as get_e_pair *)
let extract_pair : expression -> (expression * expression) result = fun e -> let extract_pair : expression -> (expression * expression) result = fun e ->
match e.expression_content with match e.expression_content with
| E_record r -> ( | E_tuple [a;b] -> ok @@ (a,b)
let lst = LMap.to_kv_list r in
match lst with
| [(Label "O",a);(Label "1",b)]
| [(Label "1",b);(Label "0",a)] ->
ok (a , b)
| _ -> fail @@ bad_kind "pair" e.location
)
| _ -> fail @@ bad_kind "pair" e.location | _ -> fail @@ bad_kind "pair" e.location
let extract_list : expression -> (expression list) result = fun e -> let extract_list : expression -> (expression list) result = fun e ->

View File

@ -80,9 +80,11 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option
val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression
val e_skip : ?loc:Location.t -> unit -> expression val e_skip : ?loc:Location.t -> unit -> expression
@ -90,9 +92,11 @@ val e_list : ?loc:Location.t -> expression list -> expression
val e_set : ?loc:Location.t -> expression list -> expression val e_set : ?loc:Location.t -> expression list -> expression
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
@ -106,12 +110,8 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple : ?loc:Location.t -> expression list -> expression
val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression
(*
val get_e_accessor : expression' -> ( expression * access_path ) result
*)
val assert_e_accessor : expression_content -> unit result val assert_e_accessor : expression_content -> unit result

View File

@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| E_record_update _, _ -> | E_record_update _, _ ->
simple_fail "comparing record update with other expression" simple_fail "comparing record update with other expression"
| E_tuple lsta, E_tuple lstb -> (
let%bind lst =
generic_try (simple_error "tuples with different number of elements")
(fun () -> List.combine lsta lstb) in
let%bind _all = bind_list @@ List.map assert_value_eq lst in
ok ()
)
| E_tuple _, _ ->
simple_fail "comparing tuple with other expression"
| E_tuple_update uta, E_tuple_update utb ->
let _ =
generic_try (simple_error "Updating different tuple") @@
fun () -> assert_value_eq (uta.tuple, utb.tuple) in
let () = assert (uta.path == utb.path) in
let%bind () = assert_value_eq (uta.update,utb.update) in
ok ()
| E_tuple_update _, _ ->
simple_fail "comparing tuple update with other expression"
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
let%bind lst = generic_try (simple_error "maps of different lengths") let%bind lst = generic_try (simple_error "maps of different lengths")
(fun () -> (fun () ->
@ -182,8 +202,10 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
| (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr)
| (E_variable _, _) | (E_lambda _, _) | (E_variable _, _) | (E_lambda _, _)
| (E_application _, _) | (E_let_in _, _) | (E_application _, _) | (E_let_in _, _)
| (E_recursive _,_) | (E_record_accessor _, _) | (E_recursive _,_)
| (E_look_up _, _) | (E_matching _, _) | (E_record_accessor _, _) | (E_tuple_accessor _, _)
| (E_look_up _, _)
| (E_matching _, _) | (E_cond _, _)
| (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value"
let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b)

View File

@ -2,17 +2,31 @@
module Location = Simple_utils.Location module Location = Simple_utils.Location
module Ast_sugar_parameter = struct
type type_meta = unit
end
include Stage_common.Types include Stage_common.Types
(*include Ast_generic_type(Ast_core_parameter) type type_content =
*) | T_sum of type_expression constructor_map
include Ast_generic_type (Ast_sugar_parameter) | T_record of type_expression label_map
| T_tuple of type_expression list
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
and arrow = {type1: type_expression; type2: type_expression}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_expression * type_expression
| TC_big_map of type_expression * type_expression
| TC_arrow of type_expression * type_expression
and type_expression = {type_content: type_content}
type inline = bool
type program = declaration Location.wrap list type program = declaration Location.wrap list
and declaration = and declaration =
| Declaration_type of (type_variable * type_expression) | Declaration_type of (type_variable * type_expression)
@ -22,7 +36,7 @@ and declaration =
* an optional type annotation * an optional type annotation
* a boolean indicating whether it should be inlined * a boolean indicating whether it should be inlined
* an expression *) * an expression *)
| Declaration_constant of (expression_variable * type_expression option * inline * expression) | Declaration_constant of (expression_variable * type_expression option * bool * expression)
(* | Macro_declaration of macro_declaration *) (* | Macro_declaration of macro_declaration *)
and expression = {expression_content: expression_content; location: Location.t} and expression = {expression_content: expression_content; location: Location.t}
@ -41,13 +55,17 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of accessor | E_record_accessor of record_accessor
| E_record_update of update | E_record_update of record_update
(* Advanced *) (* Advanced *)
| E_ascription of ascription | E_ascription of ascription
(* Sugar *) (* Sugar *)
| E_cond of conditional
| E_sequence of sequence | E_sequence of sequence
| E_skip | E_skip
| E_tuple of expression list
| E_tuple_accessor of tuple_accessor
| E_tuple_update of tuple_update
(* Data Structures *) (* Data Structures *)
| E_map of (expression * expression) list | E_map of (expression * expression) list
| E_big_map of (expression * expression) list | E_big_map of (expression * expression) list
@ -86,9 +104,8 @@ and let_in = {
and constructor = {constructor: constructor'; element: expression} and constructor = {constructor: constructor'; element: expression}
and accessor = {record: expression; label: label} and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content and matching_expr = (expr,unit) matching_content
and matching = and matching =
@ -97,11 +114,20 @@ and matching =
} }
and ascription = {anno_expr: expression; type_annotation: type_expression} and ascription = {anno_expr: expression; type_annotation: type_expression}
and conditional = {
condition : expression ;
then_clause : expression ;
else_clause : expression ;
}
and sequence = { and sequence = {
expr1: expression ; expr1: expression ;
expr2: expression ; expr2: expression ;
} }
and tuple_accessor = {tuple: expression; path: int}
and tuple_update = {tuple: expression; path: int ; update: expression}
and environment_element_definition = and environment_element_definition =
| ED_binder | ED_binder
| ED_declaration of (expression * free_variables) | ED_declaration of (expression * free_variables)

View File

@ -19,20 +19,20 @@ and expression_content ppf (ec : expression_content) =
| E_variable n -> | E_variable n ->
fprintf ppf "%a" expression_variable n fprintf ppf "%a" expression_variable n
| E_application {lamb;args} -> | E_application {lamb;args} ->
fprintf ppf "(%a)@(%a)" expression lamb expression args fprintf ppf "@[<hv>(%a)@@(%a)@]" expression lamb expression args
| E_constructor c -> | E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element fprintf ppf "@[%a(%a)@]" constructor c.constructor expression c.element
| E_constant c -> | E_constant c ->
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression)
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra -> | E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.label fprintf ppf "@[%a.%a@]" expression ra.record label ra.path
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression record label path expression update
| E_lambda {binder; input_type; output_type; result} -> | E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" fprintf ppf "@[lambda (%a:%a) : %a@ return@ %a@]"
expression_variable binder expression_variable binder
(PP_helpers.option type_expression) (PP_helpers.option type_expression)
input_type input_type
@ -44,10 +44,10 @@ and expression_content ppf (ec : expression_content) =
type_expression fun_type type_expression fun_type
expression_content (E_lambda lambda) expression_content (E_lambda lambda)
| E_matching {matchee; cases; _} -> | E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression) fprintf ppf "@[match %a with@ %a@]" expression matchee (matching expression)
cases cases
| E_let_in { let_binder ;rhs ; let_result; inline } -> | E_let_in { let_binder ;rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_ascription {anno_expr; type_annotation} -> | E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation type_annotation
@ -61,27 +61,27 @@ and option_type_name ppf
fprintf ppf "%a : %a" expression_variable n type_expression ty fprintf ppf "%a : %a" expression_variable n type_expression ty
and assoc_expression ppf : expr * expr -> unit = and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b fun (a, b) -> fprintf ppf "@[<2>%a ->@;<1 2>%a@]" expression a expression b
and single_record_patch ppf ((p, expr) : label * expr) = and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr fprintf ppf "%a <- %a" label p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) -> fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
fun f ppf m -> match m with fun f ppf m -> match m with
| Match_tuple ((lst, b), _) -> | Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "@[<hv>%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false fprintf ppf "@[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons fprintf ppf "@[<hv>| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} -> | Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some fprintf ppf "@[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some
(* Shows the type expected for the matched value *) (* Shows the type expected for the matched value *)
and matching_type ppf m = match m with and matching_type ppf m = match m with
@ -101,22 +101,22 @@ and matching_variant_case_type ppf ((c,n),_a) =
and option_mut ppf mut = and option_mut ppf mut =
if mut then if mut then
fprintf ppf "[@mut]" fprintf ppf "[@@mut]"
else else
fprintf ppf "" fprintf ppf ""
and option_inline ppf inline = and option_inline ppf inline =
if inline then if inline then
fprintf ppf "[@inline]" fprintf ppf "[@@inline]"
else else
fprintf ppf "" fprintf ppf ""
let declaration ppf (d : declaration) = let declaration ppf (d : declaration) =
match d with match d with
| Declaration_type (type_name, te) -> | Declaration_type (type_name, te) ->
fprintf ppf "type %a = %a" type_variable type_name type_expression te fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te
| Declaration_constant (name, ty_opt, i, expr) -> | Declaration_constant (name, ty_opt, i, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression
expr expr
option_inline i option_inline i

View File

@ -114,8 +114,8 @@ let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_na
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b}
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b
let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_variable ?loc v = make_expr ?loc @@ E_variable v
let e_let_in ?loc (binder, ascr) inline rhs let_result = let e_let_in ?loc (binder, ascr) inline rhs let_result =
make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline }
@ -139,7 +139,7 @@ let e_record ?loc map =
let lst = Map.String.to_kv_list map in let lst = Map.String.to_kv_list map in
e_record_ez ?loc lst e_record_ez ?loc lst
let e_update ?loc record path update = let e_record_update ?loc record path update =
let path = Label path in let path = Label path in
make_expr ?loc @@ E_record_update {record; path; update} make_expr ?loc @@ E_record_update {record; path; update}
@ -178,20 +178,20 @@ let e_assign_with_let ?loc var access_path expr =
| lst -> | lst ->
let rec aux path record= match path with let rec aux path record= match path with
| [] -> failwith "acces_path cannot be empty" | [] -> failwith "acces_path cannot be empty"
| [e] -> e_update ?loc record e expr | [e] -> e_record_update ?loc record e expr
| elem::tail -> | elem::tail ->
let next_record = e_accessor record elem in let next_record = e_record_accessor record elem in
e_update ?loc record elem (aux tail next_record ) e_record_update ?loc record elem (aux tail next_record )
in in
(var, None), true, (aux lst (e_variable var)), false (var, None), true, (aux lst (e_variable var)), false
let get_e_accessor = fun t -> let get_e_record_accessor = fun t ->
match t with match t with
| E_record_accessor {record; label} -> ok (record , label) | E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let assert_e_accessor = fun t -> let assert_e_record_accessor = fun t ->
let%bind _ = get_e_accessor t in let%bind _ = get_e_record_accessor t in
ok () ok ()
let get_e_pair = fun t -> let get_e_pair = fun t ->
@ -218,16 +218,9 @@ let get_e_list = fun t ->
in in
aux t aux t
let tuple_of_record (m: _ LMap.t) =
let aux i =
let opt = LMap.find_opt (Label (string_of_int i)) m in
Option.bind (fun opt -> Some (opt,i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let get_e_tuple = fun t -> let get_e_tuple = fun t ->
match t with match t with
| E_record r -> ok @@ tuple_of_record r | E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r
| _ -> simple_fail "ast_core: get_e_tuple: not a tuple" | _ -> simple_fail "ast_core: get_e_tuple: not a tuple"
(* Same as get_e_pair *) (* Same as get_e_pair *)

View File

@ -76,8 +76,8 @@ val e_pair : ?loc:Location.t -> expression -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
val e_accessor : ?loc:Location.t -> expression -> string -> expression val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression
val e_variable : ?loc:Location.t -> expression_variable -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
@ -95,14 +95,14 @@ val e_typed_none : ?loc:Location.t -> type_expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
(* (*
val get_e_accessor : expression' -> ( expression * access_path ) result val get_e_accessor : expression' -> ( expression * access_path ) result
*) *)
val assert_e_accessor : expression_content -> unit result val assert_e_record_accessor : expression_content -> unit result
val get_e_pair : expression_content -> ( expression * expression ) result val get_e_pair : expression_content -> ( expression * expression ) result

View File

@ -41,8 +41,8 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of accessor | E_record_accessor of record_accessor
| E_record_update of update | E_record_update of record_update
(* Advanced *) (* Advanced *)
| E_ascription of ascription | E_ascription of ascription
@ -75,9 +75,8 @@ and let_in =
and constructor = {constructor: constructor'; element: expression} and constructor = {constructor: constructor'; element: expression}
and accessor = {record: expression; label: label} and record_accessor = {record: expression; path: label}
and record_update = {record: expression; path: label ; update: expression}
and update = {record: expression; path: label ; update: expression}
and matching_expr = (expr,unit) matching_content and matching_expr = (expr,unit) matching_content
and matching = and matching =

View File

@ -29,7 +29,7 @@ and expression_content ppf (ec: expression_content) =
| E_record m -> | E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra -> | E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.label fprintf ppf "%a.%a" expression ra.record label ra.path
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
| E_lambda {binder; result} -> | E_lambda {binder; result} ->

View File

@ -335,7 +335,7 @@ let get_a_bool (t:expression) =
let get_a_record_accessor = fun t -> let get_a_record_accessor = fun t ->
match t.expression_content with match t.expression_content with
| E_record_accessor {record ; label} -> ok (record , label) | E_record_accessor {record; path} -> ok (record, path)
| _ -> simple_fail "not an accessor" | _ -> simple_fail "not an accessor"
let get_declaration_by_name : program -> string -> declaration result = fun p name -> let get_declaration_by_name : program -> string -> declaration result = fun p name ->

View File

@ -47,8 +47,8 @@ and expression_content =
| E_matching of matching | E_matching of matching
(* Record *) (* Record *)
| E_record of expression label_map | E_record of expression label_map
| E_record_accessor of accessor | E_record_accessor of record_accessor
| E_record_update of update | E_record_update of record_update
and constant = and constant =
{ cons_name: constant' { cons_name: constant'
@ -84,12 +84,12 @@ and constructor = {
element: expression ; element: expression ;
} }
and accessor = { and record_accessor = {
record: expression ; record: expression ;
label: label ; path: label ;
} }
and update = { and record_update = {
record: expression ; record: expression ;
path: label ; path: label ;
update: expression ; update: expression ;

View File

@ -3,23 +3,21 @@ open Simple_utils.PP_helpers
open Types open Types
open Format open Format
let list_sep_d x = list_sep x (const " , ") let list_sep_d x = list_sep x (tag " ,@ ")
let space_sep ppf () = fprintf ppf " "
let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
let rec type_variable ppf : type_value -> _ = function let rec type_variable ppf : type_value -> _ = function
| T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b | T_or(a, b) -> fprintf ppf "@[(%a) |@ (%a)@]" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b | T_pair(a, b) -> fprintf ppf "@[(%a) &@ (%a)@]" annotated a annotated b
| T_base b -> type_constant ppf b | T_base b -> type_constant ppf b
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b | T_function(a, b) -> fprintf ppf "@[(%a) ->@ (%a)@]" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v | T_map(k, v) -> fprintf ppf "@[<4>map(%a -> %a)@]" type_variable k type_variable v
| T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v | T_big_map(k, v) -> fprintf ppf "@[<9>big_map(%a -> %a)@]" type_variable k type_variable v
| T_list(t) -> fprintf ppf "list(%a)" type_variable t | T_list(t) -> fprintf ppf "@[<5>list(%a)@]" type_variable t
| T_set(t) -> fprintf ppf "set(%a)" type_variable t | T_set(t) -> fprintf ppf "@[<4>set(%a)@]" type_variable t
| T_option(o) -> fprintf ppf "option(%a)" type_variable o | T_option(o) -> fprintf ppf "@[<7>option(%a)@]" type_variable o
| T_contract(t) -> fprintf ppf "contract(%a)" type_variable t | T_contract(t) -> fprintf ppf "@[<9>contract(%a)@]" type_variable t
and annotated ppf : type_value annotated -> _ = function and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann
@ -80,30 +78,38 @@ and expression ppf (e:expression) =
and expression' ppf (e:expression') = match e with and expression' ppf (e:expression') = match e with
| E_skip -> fprintf ppf "skip" | E_skip -> fprintf ppf "skip"
| E_closure x -> fprintf ppf "C(%a)" function_ x | E_closure x -> function_ ppf x
| E_variable v -> fprintf ppf "V(%a)" Var.pp v | E_variable v -> fprintf ppf "%a" Var.pp v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b
| E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments | E_constant c -> fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments
| E_literal v -> fprintf ppf "L(%a)" value v | E_literal v -> fprintf ppf "@[L(%a)@]" value v
| E_make_none _ -> fprintf ppf "none" | E_make_none _ -> fprintf ppf "none"
| E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_bool (c, a, b) ->
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s fprintf ppf
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons "@[match %a with@ @[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]@]"
expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf
"@[match %a with@ @[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]"
expression c expression n Var.pp name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r fprintf ppf
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b "@[match %a with@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]"
expression c Var.pp name_l expression l Var.pp name_r expression r
| E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b
| E_let_in ((name , _) , inline, expr , body) -> | E_let_in ((name , _) , inline, expr , body) ->
fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body
| E_iterator (b , ((name , _) , body) , expr) -> | E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body
| E_fold (((name , _) , body) , collection , initial) -> | E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body
| E_record_update (r, path,update) -> | E_record_update (r, path,update) ->
fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update
| E_while (e , b) -> | E_while (e , b) ->
fprintf ppf "while %a do %a" expression e expression b fprintf ppf "@[while %a do %a@]" expression e expression b
and expression_with_type : _ -> expression -> _ = fun ppf e -> and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a" fprintf ppf "%a : %a"
@ -111,24 +117,22 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
type_variable e.type_value type_variable e.type_value
and function_ ppf ({binder ; body}:anon_function) = and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "fun %a -> (%a)" fprintf ppf "@[fun %a ->@ (%a)@]"
Var.pp binder Var.pp binder
expression body expression body
and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i
and option_inline ppf inline = and option_inline ppf inline =
if inline then if inline then
fprintf ppf "[@inline]" fprintf ppf "[@@inline]"
else else
fprintf ppf "" fprintf ppf ""
and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i
and tl_statement ppf (ass, _) = assignment ppf ass and tl_statement ppf (ass, _) = declaration ppf ass
and program ppf (p:program) = and program ppf (p:program) =
fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p fprintf ppf "@[<v>%a@]" (pp_print_list ~pp_sep:(tag "@ ") tl_statement) p
and constant ppf : constant' -> unit = function and constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT" | C_INT -> fprintf ppf "INT"
@ -254,9 +258,9 @@ let%expect_test _ =
let wrap e = { content = e ; type_value = dummy_type } in let wrap e = { content = e ; type_value = dummy_type } in
pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ; pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ;
[%expect{| [%expect{|
C(fun y -> (V(y))) fun y -> (y)
|}] ; |}] ;
pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ; pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ;
[%expect{| [%expect{|
C(fun z -> (V(z))) fun z -> (z)
|}] |}]

View File

@ -11,34 +11,33 @@ let label ppf (l:label) : unit =
let cmap_sep value sep ppf m = let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) = let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in let lst = LMap.to_kv_list m in
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m = let tuple_sep value sep ppf m =
assert (Helpers.is_tuple_lmap m); assert (Helpers.is_tuple_lmap m);
let lst = LMap.to_kv_list m in let lst = Helpers.tuple_of_record m in
let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in let new_pp ppf (_, v) = fprintf ppf "%a" value v in
let new_pp ppf (_k, v) = fprintf ppf "%a" value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
(* Prints records which only contain the consecutive fields (* Prints records which only contain the consecutive fields
0..(cardinal-1) as tuples *) 0..(cardinal-1) as tuples *)
let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m
else else
fprintf ppf format_record (record_sep value (const sep_record)) m fprintf ppf format_record (record_sep value (tag sep_record)) m
let list_sep_d x = list_sep x (const " , ") let list_sep_d x = list_sep x (tag " ,@ ")
let cmap_sep_d x = cmap_sep x (const " , ") let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , " let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * " let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let constant ppf : constant' -> unit = function let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT" | C_INT -> fprintf ppf "INT"
@ -156,43 +155,50 @@ let constant ppf : constant' -> unit = function
let literal ppf (l : literal) = let literal ppf (l : literal) =
match l with match l with
| Literal_unit -> | Literal_unit -> fprintf ppf "unit"
fprintf ppf "unit" | Literal_void -> fprintf ppf "void"
| Literal_void -> | Literal_bool b -> fprintf ppf "%b" b
fprintf ppf "void" | Literal_int n -> fprintf ppf "%d" n
| Literal_bool b -> | Literal_nat n -> fprintf ppf "+%d" n
fprintf ppf "%b" b | Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_int n -> | Literal_mutez n -> fprintf ppf "%dmutez" n
fprintf ppf "%d" n | Literal_string s -> fprintf ppf "%S" s
| Literal_nat n -> | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
fprintf ppf "+%d" n | Literal_address s -> fprintf ppf "@%S" s
| Literal_timestamp n -> | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
fprintf ppf "+%d" n | Literal_key s -> fprintf ppf "key %s" s
| Literal_mutez n -> | Literal_key_hash s -> fprintf ppf "key_hash %s" s
fprintf ppf "%dmutez" n | Literal_signature s -> fprintf ppf "Signature %s" s
| Literal_string s -> | Literal_chain_id s -> fprintf ppf "Chain_id %s" s
fprintf ppf "%S" s
| Literal_bytes b -> let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
| Literal_address s -> and type_constant ppf (tc : type_constant) : unit =
fprintf ppf "@%S" s let s =
| Literal_operation _ -> match tc with
fprintf ppf "Operation(...bytes)" | TC_unit -> "unit"
| Literal_key s -> | TC_string -> "string"
fprintf ppf "key %s" s | TC_bytes -> "bytes"
| Literal_key_hash s -> | TC_nat -> "nat"
fprintf ppf "key_hash %s" s | TC_int -> "int"
| Literal_signature s -> | TC_mutez -> "mutez"
fprintf ppf "Signature %s" s | TC_bool -> "bool"
| Literal_chain_id s -> | TC_operation -> "operation"
fprintf ppf "Chain_id %s" s | TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signature"
| TC_timestamp -> "timestamp"
| TC_chain_id -> "chain_id"
| TC_void -> "void"
in
fprintf ppf "%s" s
module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
module Agt=Ast_generic_type(PARAMETER) module Agt=Ast_generic_type(PARAMETER)
open Agt open Agt
open Format open Format
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
let rec type_expression' : let rec type_expression' :
(formatter -> type_expression -> unit) (formatter -> type_expression -> unit)
-> formatter -> formatter
@ -200,58 +206,16 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
-> unit = -> unit =
fun f ppf te -> fun f ppf te ->
match te.type_content with match te.type_content with
| T_sum m -> | T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
fprintf ppf "sum[%a]" (cmap_sep_d f) m | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_record m -> | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
fprintf ppf "%a" (tuple_or_record_sep_type f) m | T_variable tv -> type_variable ppf tv
| T_arrow a -> | T_constant tc -> type_constant ppf tc
fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_operator to_ -> type_operator f ppf to_
| T_variable tv ->
type_variable ppf tv
| T_constant tc ->
type_constant ppf tc
| T_operator to_ ->
type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit = and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te type_expression' type_expression ppf te
and type_constant ppf (tc : type_constant) : unit =
let s =
match tc with
| TC_unit ->
"unit"
| TC_string ->
"string"
| TC_bytes ->
"bytes"
| TC_nat ->
"nat"
| TC_int ->
"int"
| TC_mutez ->
"mutez"
| TC_bool ->
"bool"
| TC_operation ->
"operation"
| TC_address ->
"address"
| TC_key ->
"key"
| TC_key_hash ->
"key_hash"
| TC_signature ->
"signature"
| TC_timestamp ->
"timestamp"
| TC_chain_id ->
"chain_id"
| TC_void ->
"void"
in
fprintf ppf "%s" s
and type_operator : and type_operator :
(formatter -> type_expression -> unit) (formatter -> type_expression -> unit)
-> formatter -> formatter

View File

@ -46,3 +46,23 @@ let get_pair m =
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
| Some e1, Some e2 -> ok (e1,e2) | Some e1, Some e2 -> ok (e1,e2)
| _ -> simple_fail "not a pair" | _ -> simple_fail "not a pair"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let label = Label (string_of_int i) in
let opt = LMap.find_opt (label) m in
Option.bind (fun opt -> Some ((label,opt),i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
List.map snd @@ tuple_of_record m
else
List.rev @@ LMap.to_list m
let kv_list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
tuple_of_record m
else
List.rev @@ LMap.to_kv_list m

View File

@ -1,3 +1,5 @@
open Types
val bind_lmap : val bind_lmap :
('a * 'b list, 'c) result Types.label_map -> ('a * 'b list, 'c) result Types.label_map ->
('a Types.label_map * 'b list, 'c) result ('a Types.label_map * 'b list, 'c) result
@ -19,6 +21,9 @@ val is_tuple_lmap : 'a Types.label_map -> bool
val get_pair : val get_pair :
'a Types.label_map -> 'a Types.label_map ->
(('a * 'a) * 'b list, unit -> Trace.error) result (('a * 'a) * 'b list, unit -> Trace.error) result
val tuple_of_record : 'a LMap.t -> (label * 'a) list
val list_of_record_or_tuple : 'a LMap.t -> 'a list
val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list

View File

@ -136,7 +136,7 @@ module Substitution = struct
and s_matching_expr : T.matching_expr w = fun ~substs _ -> and s_matching_expr : T.matching_expr w = fun ~substs _ ->
let _TODO = substs in let _TODO = substs in
failwith "TODO: subst: unimplemented case s_matching" failwith "TODO: subst: unimplemented case s_matching"
and s_accessor : T.accessor w = fun ~substs _ -> and s_accessor : T.record_accessor w = fun ~substs _ ->
let _TODO = substs in let _TODO = substs in
failwith "TODO: subst: unimplemented case s_access_path" failwith "TODO: subst: unimplemented case s_access_path"
@ -182,10 +182,10 @@ module Substitution = struct
* let val_ = s_expression ~v ~expr val_ in * let val_ = s_expression ~v ~expr val_ in
* ok @@ (key , val_)) aemap in * ok @@ (key , val_)) aemap in
* ok @@ T.E_record aemap *) * ok @@ T.E_record aemap *)
| T.E_record_accessor {record=e;label} -> | T.E_record_accessor {record=e;path} ->
let%bind record = s_expression ~substs e in let%bind record = s_expression ~substs e in
let%bind label = s_label ~substs label in let%bind path = s_label ~substs path in
ok @@ T.E_record_accessor {record;label} ok @@ T.E_record_accessor {record;path}
| T.E_record_update {record;path;update}-> | T.E_record_update {record;path;update}->
let%bind record = s_expression ~substs record in let%bind record = s_expression ~substs record in
let%bind update = s_expression ~substs update in let%bind update = s_expression ~substs update in

View File

@ -13,6 +13,11 @@ const fb : foobar = (0,0)
function projection (const tpl : foobar) : int is tpl.0 + tpl.1 function projection (const tpl : foobar) : int is tpl.0 + tpl.1
type big_tuple is int * int * int * int * int type big_tuple is int * int * int * int * int * int * int * int * int * int * int * int
const br : big_tuple = (23, 23, 23, 23, 23) const br : big_tuple = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
function update (const tpl : big_tuple) : big_tuple is
block {
tpl.11 := 2048
} with tpl

View File

@ -876,9 +876,14 @@ let tuple () : unit result =
expect_eq_n program "modify_abc" make_input make_expected expect_eq_n program "modify_abc" make_input make_expected
in in
let%bind () = let%bind () =
let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in let expected = ez [0 ; 1 ; 2 ; 3 ; 4; 5; 6; 7; 8; 9; 10; 11] in
expect_eq_evaluate program "br" expected expect_eq_evaluate program "br" expected
in in
let%bind () =
let make_input = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; n] in
let make_expected = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; 2048] in
expect_eq_n program "update" make_input make_expected
in
ok () ok ()
let tuple_mligo () : unit result = let tuple_mligo () : unit result =

View File

@ -1,38 +0,0 @@
const commonUtils = require('./common-utils');
const API_HOST = commonUtils.API_HOST;
const runCommandAndGetOutputFor = commonUtils.runCommandAndGetOutputFor;
const clearText = commonUtils.clearText;
const COMMAND = 'deploy';
const COMMAND_ENDPOINT = 'deploy';
async function deploy() {
return await runCommandAndGetOutputFor(COMMAND, COMMAND_ENDPOINT);
}
describe('Deploy contract', () => {
beforeAll(() => jest.setTimeout(60000));
beforeEach(async () => await page.goto(API_HOST));
it('should deploy', async done => {
expect(await deploy()).toContain('The contract was successfully deployed to the carthage test network.');
done();
});
it('should fail to deploy contract with invalid storage', async done => {
await page.click('#command-select');
await page.click(`#deploy`);
await page.click(`#storage`);
await clearText(page.keyboard);
await page.keyboard.type('asdf');
expect(await deploy()).toContain('Error: ');
done();
});
});