Merge branch 'ast/move_ds_to_constant' into 'dev'
Remove extra AST cases See merge request ligolang/ligo!499
This commit is contained in:
commit
9cd750442a
@ -7,7 +7,7 @@ dry_run_output=$(./scripts/ligo_ci.sh dry-run src/test/contracts/website2.ligo m
|
|||||||
|
|
||||||
expected_compiled_parameter="(Right 1)";
|
expected_compiled_parameter="(Right 1)";
|
||||||
expected_compiled_storage=1;
|
expected_compiled_storage=1;
|
||||||
expected_dry_run_output="( list[] , 2 )";
|
expected_dry_run_output="( LIST_EMPTY() , 2 )";
|
||||||
|
|
||||||
if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
|
if [ "$compiled_storage" != "$expected_compiled_storage" ]; then
|
||||||
echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead";
|
echo "Expected $expected_compiled_storage as compile-storage output, got $compiled_storage instead";
|
||||||
|
@ -7,13 +7,13 @@ let bad_contract basename =
|
|||||||
|
|
||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
|
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
|
||||||
[%expect {| 1870 bytes |}] ;
|
[%expect {| 1872 bytes |}] ;
|
||||||
|
|
||||||
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
|
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
|
||||||
[%expect {| 1294 bytes |}] ;
|
[%expect {| 1294 bytes |}] ;
|
||||||
|
|
||||||
run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ;
|
run_ligo_good [ "measure-contract" ; contract "multisig-v2.ligo" ; "main" ] ;
|
||||||
[%expect {| 2935 bytes |}] ;
|
[%expect {| 2974 bytes |}] ;
|
||||||
|
|
||||||
run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ;
|
run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ;
|
||||||
[%expect {| 589 bytes |}] ;
|
[%expect {| 589 bytes |}] ;
|
||||||
@ -227,16 +227,17 @@ let%expect_test _ =
|
|||||||
NIL operation ;
|
NIL operation ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
CONS ;
|
CONS ;
|
||||||
DIP { DIP 4 { DUP } ;
|
DUP ;
|
||||||
DIG 4 ;
|
DIP { DIP 5 { DUP } ;
|
||||||
DIP 4 { DUP } ;
|
DIG 5 ;
|
||||||
DIG 4 ;
|
DIP 5 { DUP } ;
|
||||||
|
DIG 5 ;
|
||||||
DIP { DUP ; CDR ; SWAP ; CAR ; CAR } ;
|
DIP { DUP ; CDR ; SWAP ; CAR ; CAR } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
PAIR } ;
|
PAIR } ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP { DROP 13 } } ;
|
DIP { DROP 14 } } ;
|
||||||
DIP { DROP } }
|
DIP { DROP } }
|
||||||
{ DUP ;
|
{ DUP ;
|
||||||
DIP { DIP { DUP } ; SWAP } ;
|
DIP { DIP { DUP } ; SWAP } ;
|
||||||
@ -513,19 +514,19 @@ let%expect_test _ =
|
|||||||
GT ;
|
GT ;
|
||||||
IF { PUSH string "Message size exceed maximum limit" ; FAILWITH }
|
IF { PUSH string "Message size exceed maximum limit" ; FAILWITH }
|
||||||
{ PUSH unit Unit } ;
|
{ PUSH unit Unit } ;
|
||||||
DIP 4 { DUP } ;
|
|
||||||
DIG 4 ;
|
|
||||||
EMPTY_SET address ;
|
EMPTY_SET address ;
|
||||||
|
DUP ;
|
||||||
|
DIP { DIP 5 { DUP } ; DIG 5 } ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP 2 { DUP } ;
|
DIP 3 { DUP } ;
|
||||||
DIG 2 ;
|
DIG 3 ;
|
||||||
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } ;
|
DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } ;
|
||||||
GET ;
|
GET ;
|
||||||
IF_NONE
|
IF_NONE
|
||||||
{ DIP 5 { DUP } ;
|
{ DIP 6 { DUP } ;
|
||||||
DIG 5 ;
|
|
||||||
DIP 6 { DUP } ;
|
|
||||||
DIG 6 ;
|
DIG 6 ;
|
||||||
|
DIP 7 { DUP } ;
|
||||||
|
DIG 7 ;
|
||||||
CDR ;
|
CDR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
@ -535,7 +536,7 @@ let%expect_test _ =
|
|||||||
PUSH nat 1 ;
|
PUSH nat 1 ;
|
||||||
ADD ;
|
ADD ;
|
||||||
SOME ;
|
SOME ;
|
||||||
DIP { DIP 6 { DUP } ; DIG 6 ; CDR ; CAR ; CAR } ;
|
DIP { DIP 7 { DUP } ; DIG 7 ; CDR ; CAR ; CAR } ;
|
||||||
SENDER ;
|
SENDER ;
|
||||||
UPDATE ;
|
UPDATE ;
|
||||||
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
|
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
|
||||||
@ -543,31 +544,33 @@ let%expect_test _ =
|
|||||||
PAIR ;
|
PAIR ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP { DUP } ;
|
|
||||||
SWAP ;
|
|
||||||
CAR ;
|
|
||||||
DIP { DUP } ;
|
|
||||||
PAIR ;
|
|
||||||
EMPTY_SET address ;
|
EMPTY_SET address ;
|
||||||
PUSH bool True ;
|
PUSH bool True ;
|
||||||
SENDER ;
|
SENDER ;
|
||||||
UPDATE ;
|
UPDATE ;
|
||||||
|
DIP 2 { DUP } ;
|
||||||
|
DIG 2 ;
|
||||||
|
DIP 2 { DUP } ;
|
||||||
|
DIG 2 ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
|
CAR ;
|
||||||
|
PAIR ;
|
||||||
CDR ;
|
CDR ;
|
||||||
|
DIP { DUP } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP { DROP } }
|
DIP { DROP 2 } }
|
||||||
{ DIP 6 { DUP } ;
|
{ DIP 7 { DUP } ;
|
||||||
DIG 6 ;
|
DIG 7 ;
|
||||||
DIP { DUP } ;
|
DIP { DUP } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
SENDER ;
|
SENDER ;
|
||||||
MEM ;
|
MEM ;
|
||||||
IF { DUP }
|
IF { DUP }
|
||||||
{ DIP 7 { DUP } ;
|
{ DIP 8 { DUP } ;
|
||||||
DIG 7 ;
|
|
||||||
DIP 8 { DUP } ;
|
|
||||||
DIG 8 ;
|
DIG 8 ;
|
||||||
|
DIP 9 { DUP } ;
|
||||||
|
DIG 9 ;
|
||||||
CDR ;
|
CDR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
@ -577,7 +580,7 @@ let%expect_test _ =
|
|||||||
PUSH nat 1 ;
|
PUSH nat 1 ;
|
||||||
ADD ;
|
ADD ;
|
||||||
SOME ;
|
SOME ;
|
||||||
DIP { DIP 8 { DUP } ; DIG 8 ; CDR ; CAR ; CAR } ;
|
DIP { DIP 9 { DUP } ; DIG 9 ; CDR ; CAR ; CAR } ;
|
||||||
SENDER ;
|
SENDER ;
|
||||||
UPDATE ;
|
UPDATE ;
|
||||||
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
|
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CDR } ;
|
||||||
@ -623,21 +626,21 @@ let%expect_test _ =
|
|||||||
GT ;
|
GT ;
|
||||||
IF { PUSH string "Maximum number of proposal reached" ; FAILWITH }
|
IF { PUSH string "Maximum number of proposal reached" ; FAILWITH }
|
||||||
{ PUSH unit Unit } ;
|
{ PUSH unit Unit } ;
|
||||||
DIP 2 { DUP } ;
|
|
||||||
DIG 2 ;
|
|
||||||
NIL operation ;
|
NIL operation ;
|
||||||
|
DUP ;
|
||||||
|
DIP { DIP 3 { DUP } ; DIG 3 } ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP 4 { DUP } ;
|
DIP 5 { DUP } ;
|
||||||
DIG 4 ;
|
DIG 5 ;
|
||||||
SIZE ;
|
SIZE ;
|
||||||
DIP { DIP 3 { DUP } ; DIG 3 ; CDR ; CDR } ;
|
DIP { DIP 4 { DUP } ; DIG 4 ; CDR ; CDR } ;
|
||||||
COMPARE ;
|
COMPARE ;
|
||||||
GE ;
|
GE ;
|
||||||
IF { DIP 3 { DUP } ;
|
IF { DIP 4 { DUP } ;
|
||||||
DIG 3 ;
|
DIG 4 ;
|
||||||
DIP 9 { DUP } ;
|
DIP 11 { DUP } ;
|
||||||
DIG 9 ;
|
DIG 11 ;
|
||||||
DIP { DIP 4 { DUP } ; DIG 4 ; CAR ; CDR ; CDR ; NONE (set address) } ;
|
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR ; NONE (set address) } ;
|
||||||
UPDATE ;
|
UPDATE ;
|
||||||
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
|
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
@ -649,7 +652,7 @@ let%expect_test _ =
|
|||||||
CDR ;
|
CDR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
CDR ;
|
CDR ;
|
||||||
DIP { DIP 10 { DUP } ; DIG 10 } ;
|
DIP { DIP 12 { DUP } ; DIG 12 } ;
|
||||||
EXEC ;
|
EXEC ;
|
||||||
DIP { DUP } ;
|
DIP { DUP } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
@ -658,7 +661,7 @@ let%expect_test _ =
|
|||||||
CDR ;
|
CDR ;
|
||||||
CAR ;
|
CAR ;
|
||||||
CDR ;
|
CDR ;
|
||||||
DIP { DIP 11 { DUP } ; DIG 11 } ;
|
DIP { DIP 13 { DUP } ; DIG 13 } ;
|
||||||
CONCAT ;
|
CONCAT ;
|
||||||
SHA256 ;
|
SHA256 ;
|
||||||
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CAR } ;
|
DIP { DUP ; CAR ; SWAP ; CDR ; DUP ; CDR ; SWAP ; CAR ; CAR } ;
|
||||||
@ -684,7 +687,7 @@ let%expect_test _ =
|
|||||||
SWAP ;
|
SWAP ;
|
||||||
DIP { DUP } ;
|
DIP { DUP } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
DIP { DIP 11 { DUP } ; DIG 11 } ;
|
DIP { DIP 12 { DUP } ; DIG 12 } ;
|
||||||
MEM ;
|
MEM ;
|
||||||
IF { DIP 2 { DUP } ;
|
IF { DIP 2 { DUP } ;
|
||||||
DIG 2 ;
|
DIG 2 ;
|
||||||
@ -746,14 +749,14 @@ let%expect_test _ =
|
|||||||
PAIR ;
|
PAIR ;
|
||||||
DIP { DROP 4 } }
|
DIP { DROP 4 } }
|
||||||
{ DUP ;
|
{ DUP ;
|
||||||
DIP 4 { DUP } ;
|
DIP 5 { DUP } ;
|
||||||
DIG 4 ;
|
DIG 5 ;
|
||||||
DIP 10 { DUP } ;
|
DIP 12 { DUP } ;
|
||||||
DIG 10 ;
|
DIG 12 ;
|
||||||
DIP { DIP 6 { DUP } ;
|
DIP { DIP 7 { DUP } ;
|
||||||
DIG 6 ;
|
DIG 7 ;
|
||||||
SOME ;
|
SOME ;
|
||||||
DIP { DIP 5 { DUP } ; DIG 5 ; CAR ; CDR ; CDR } } ;
|
DIP { DIP 6 { DUP } ; DIG 6 ; CAR ; CDR ; CDR } } ;
|
||||||
UPDATE ;
|
UPDATE ;
|
||||||
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
|
DIP { DUP ; CDR ; SWAP ; CAR ; DUP ; CAR ; SWAP ; CDR ; CAR } ;
|
||||||
SWAP ;
|
SWAP ;
|
||||||
@ -768,7 +771,7 @@ let%expect_test _ =
|
|||||||
CAR ;
|
CAR ;
|
||||||
DIP { DUP ; CDR } ;
|
DIP { DUP ; CDR } ;
|
||||||
PAIR ;
|
PAIR ;
|
||||||
DIP { DROP 15 } } ;
|
DIP { DROP 17 } } ;
|
||||||
DIP { DROP } }
|
DIP { DROP } }
|
||||||
{ DUP ;
|
{ DUP ;
|
||||||
DIP { DIP { DUP } ; SWAP } ;
|
DIP { DIP { DUP } ; SWAP } ;
|
||||||
@ -1033,11 +1036,11 @@ let%expect_test _ =
|
|||||||
|
|
||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "dry-run" ; contract "redeclaration.ligo" ; "main" ; "unit" ; "0" ] ;
|
run_ligo_good [ "dry-run" ; contract "redeclaration.ligo" ; "main" ; "unit" ; "0" ] ;
|
||||||
[%expect {|( list[] , 0 ) |}]
|
[%expect {|( LIST_EMPTY() , 0 ) |}]
|
||||||
|
|
||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "dry-run" ; contract "double_main.ligo" ; "main" ; "unit" ; "0" ] ;
|
run_ligo_good [ "dry-run" ; contract "double_main.ligo" ; "main" ; "unit" ; "0" ] ;
|
||||||
[%expect {|( list[] , 2 ) |}]
|
[%expect {|( LIST_EMPTY() , 2 ) |}]
|
||||||
|
|
||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "compile-contract" ; contract "subtle_nontail_fail.mligo" ; "main" ] ;
|
run_ligo_good [ "compile-contract" ; contract "subtle_nontail_fail.mligo" ; "main" ] ;
|
||||||
@ -1095,7 +1098,7 @@ let%expect_test _ =
|
|||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ;
|
run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ;
|
||||||
[%expect {|
|
[%expect {|
|
||||||
( list[] , 3 ) |}]
|
( LIST_EMPTY() , 3 ) |}]
|
||||||
|
|
||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ;
|
run_ligo_bad [ "compile-contract" ; bad_contract "redundant_constructors.mligo" ; "main" ] ;
|
||||||
@ -1114,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[] : (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 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"}
|
||||||
|
|
||||||
|
|
||||||
If you're not sure how to fix this error, you can
|
If you're not sure how to fix this error, you can
|
||||||
@ -1127,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[] : (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 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"}
|
||||||
|
|
||||||
|
|
||||||
If you're not sure how to fix this error, you can
|
If you're not sure how to fix this error, you can
|
||||||
|
@ -43,12 +43,12 @@ let%expect_test _ =
|
|||||||
val map_finds = Some(2 : int)
|
val map_finds = Some(2 : int)
|
||||||
val map_finds_fail = "failed map find" : failure
|
val map_finds_fail = "failed map find" : failure
|
||||||
val map_empty = { ; 0 = ([]) ; 1 = ([]) }
|
val map_empty = { ; 0 = ([]) ; 1 = ([]) }
|
||||||
val m = [ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]
|
val m = [ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : int]
|
||||||
val map_fold = 4 : int
|
val map_fold = 4 : int
|
||||||
val map_iter = unit
|
val map_iter = unit
|
||||||
val map_map = [ ; "one" : string -> 4 : int ; "two" : string -> 5 : int ; "three" : string -> 8 : int]
|
val map_map = [ ; "one" : string -> 4 : int ; "three" : string -> 8 : int ; "two" : string -> 5 : int]
|
||||||
val map_mem = { ; 0 = (true) ; 1 = (false) }
|
val map_mem = { ; 0 = (true) ; 1 = (false) }
|
||||||
val map_remove = { ; 0 = ([ ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) }
|
val map_remove = { ; 0 = ([ ; "three" : string -> 3 : int ; "two" : string -> 2 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "three" : string -> 3 : int ; "two" : string -> 2 : int]) }
|
||||||
val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) }
|
val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) }
|
||||||
val s = { ; 1 : int ; 2 : int ; 3 : int}
|
val s = { ; 1 : int ; 2 : int ; 3 : int}
|
||||||
val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) }
|
val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) }
|
||||||
|
@ -175,7 +175,7 @@ let%expect_test _ =
|
|||||||
let%expect_test _ =
|
let%expect_test _ =
|
||||||
run_ligo_good [ "interpret" ; "Set.literal [ (1,(2,3)) ; (2,(3,4)) ]" ; "--syntax=cameligo" ] ;
|
run_ligo_good [ "interpret" ; "Set.literal [ (1,(2,3)) ; (2,(3,4)) ]" ; "--syntax=cameligo" ] ;
|
||||||
[%expect {|
|
[%expect {|
|
||||||
set[( 2 , ( 3 , 4 ) ) , ( 1 , ( 2 , 3 ) )] |}];
|
SET_ADD(( 2 , ( 3 , 4 ) ) , SET_ADD(( 1 , ( 2 , 3 ) ) , SET_EMPTY())) |}];
|
||||||
|
|
||||||
run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ;
|
run_ligo_bad [ "interpret" ; "Set.literal [ (1,2,3) ; (2,3,4) ]" ; "--syntax=cameligo" ] ;
|
||||||
[%expect {|
|
[%expect {|
|
||||||
|
@ -119,6 +119,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
|
|||||||
| ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b')
|
| ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b')
|
||||||
| ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b')
|
| ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b')
|
||||||
| ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) )
|
| ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) )
|
||||||
|
| ( C_LIST_EMPTY, []) -> ok @@ V_List ([])
|
||||||
| ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
|
| ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) ->
|
||||||
let%bind elts' = bind_map_list
|
let%bind elts' = bind_map_list
|
||||||
(fun elt ->
|
(fun elt ->
|
||||||
@ -170,6 +171,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
|
|||||||
eval body env'
|
eval body env'
|
||||||
)
|
)
|
||||||
init elts
|
init elts
|
||||||
|
| ( C_MAP_EMPTY , []) -> ok @@ V_Map ([])
|
||||||
| ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) ->
|
| ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) ->
|
||||||
bind_fold_list
|
bind_fold_list
|
||||||
(fun prev kv ->
|
(fun prev kv ->
|
||||||
@ -188,6 +190,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
|
|||||||
| "None" -> ok @@ V_Map (List.remove_assoc k kvs)
|
| "None" -> ok @@ V_Map (List.remove_assoc k kvs)
|
||||||
| _ -> simple_fail "update without an option"
|
| _ -> simple_fail "update without an option"
|
||||||
)
|
)
|
||||||
|
| ( C_SET_EMPTY, []) -> ok @@ V_Set ([])
|
||||||
| ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l))
|
| ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l))
|
||||||
| ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) ->
|
| ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) ->
|
||||||
bind_fold_list
|
bind_fold_list
|
||||||
@ -289,22 +292,6 @@ and eval : Ast_typed.expression -> env -> value result
|
|||||||
let%bind rhs' = eval rhs env in
|
let%bind rhs' = eval rhs env in
|
||||||
eval let_result (Env.extend env (let_binder,rhs'))
|
eval let_result (Env.extend env (let_binder,rhs'))
|
||||||
)
|
)
|
||||||
| E_map kvlist | E_big_map kvlist ->
|
|
||||||
let%bind kvlist' = bind_map_list
|
|
||||||
(fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv)
|
|
||||||
kvlist in
|
|
||||||
ok @@ V_Map kvlist'
|
|
||||||
| E_list expl ->
|
|
||||||
let%bind expl' = bind_map_list
|
|
||||||
(fun (exp:Ast_typed.expression) -> eval exp env)
|
|
||||||
expl in
|
|
||||||
ok @@ V_List expl'
|
|
||||||
| E_set expl ->
|
|
||||||
let%bind expl' = bind_map_list
|
|
||||||
(fun (exp:Ast_typed.expression) -> eval exp env)
|
|
||||||
(List.sort_uniq compare expl)
|
|
||||||
in
|
|
||||||
ok @@ V_Set expl'
|
|
||||||
| E_literal l ->
|
| E_literal l ->
|
||||||
eval_literal l
|
eval_literal l
|
||||||
| E_variable var ->
|
| E_variable var ->
|
||||||
@ -378,9 +365,6 @@ and eval : Ast_typed.expression -> env -> value result
|
|||||||
)
|
)
|
||||||
| E_recursive {fun_name; fun_type=_; lambda} ->
|
| E_recursive {fun_name; fun_type=_; lambda} ->
|
||||||
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
|
ok @@ V_Func_rec (fun_name, lambda.binder, lambda.result, env)
|
||||||
| E_look_up _ ->
|
|
||||||
let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in
|
|
||||||
simple_fail serr
|
|
||||||
|
|
||||||
let dummy : Ast_typed.program -> string result =
|
let dummy : Ast_typed.program -> string result =
|
||||||
fun prg ->
|
fun prg ->
|
||||||
|
@ -141,6 +141,8 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
|
|||||||
| T_operator (TC_big_map (key,value)) ->
|
| T_operator (TC_big_map (key,value)) ->
|
||||||
let%bind kv' = bind_map_pair transpile_type (key, value) in
|
let%bind kv' = bind_map_pair transpile_type (key, value) in
|
||||||
ok (T_big_map kv')
|
ok (T_big_map kv')
|
||||||
|
| T_operator (TC_map_or_big_map (_,_)) ->
|
||||||
|
fail @@ corner_case ~loc:"transpiler" "TC_map_or_big_map should have been resolved before transpilation"
|
||||||
| T_operator (TC_list t) ->
|
| T_operator (TC_list t) ->
|
||||||
let%bind t' = transpile_type t in
|
let%bind t' = transpile_type t in
|
||||||
ok (T_list t')
|
ok (T_list t')
|
||||||
@ -234,7 +236,6 @@ and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression
|
|||||||
and transpile_annotated_expression (ae:AST.expression) : expression result =
|
and transpile_annotated_expression (ae:AST.expression) : expression result =
|
||||||
let%bind tv = transpile_type ae.type_expression in
|
let%bind tv = transpile_type ae.type_expression in
|
||||||
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
|
let return ?(tv = tv) expr = ok @@ Combinators.Expression.make_tpl (expr, tv) in
|
||||||
let f = transpile_annotated_expression in
|
|
||||||
let info =
|
let info =
|
||||||
let title () = "translating expression" in
|
let title () = "translating expression" in
|
||||||
let content () = Format.asprintf "%a" Location.pp ae.location in
|
let content () = Format.asprintf "%a" Location.pp ae.location in
|
||||||
@ -391,58 +392,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
transpile_lambda l io
|
transpile_lambda l io
|
||||||
| E_recursive r ->
|
| E_recursive r ->
|
||||||
transpile_recursive r
|
transpile_recursive r
|
||||||
| E_list lst -> (
|
|
||||||
let%bind t =
|
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a list") @@
|
|
||||||
get_t_list tv in
|
|
||||||
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
|
|
||||||
let aux : expression -> expression -> expression result = fun prev cur ->
|
|
||||||
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
|
|
||||||
let%bind (init : expression) = return @@ E_make_empty_list t in
|
|
||||||
bind_fold_right_list aux init lst'
|
|
||||||
)
|
|
||||||
| E_set lst -> (
|
|
||||||
let%bind t =
|
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a set") @@
|
|
||||||
get_t_set tv in
|
|
||||||
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
|
|
||||||
let aux : expression -> expression -> expression result = fun prev cur ->
|
|
||||||
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
|
|
||||||
let%bind (init : expression) = return @@ E_make_empty_set t in
|
|
||||||
bind_fold_list aux init lst'
|
|
||||||
)
|
|
||||||
| E_map m -> (
|
|
||||||
let%bind (src, dst) =
|
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a map") @@
|
|
||||||
Mini_c.Combinators.get_t_map tv in
|
|
||||||
let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
|
|
||||||
let%bind prev' = prev in
|
|
||||||
let%bind (k', v') =
|
|
||||||
let v' = e_a_some v ae.environment in
|
|
||||||
bind_map_pair (transpile_annotated_expression) (k , v') in
|
|
||||||
return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
|
|
||||||
in
|
|
||||||
let init = return @@ E_make_empty_map (src, dst) in
|
|
||||||
List.fold_left aux init m
|
|
||||||
)
|
|
||||||
| E_big_map m -> (
|
|
||||||
let%bind (src, dst) =
|
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a map") @@
|
|
||||||
Mini_c.Combinators.get_t_big_map tv in
|
|
||||||
let aux : expression result -> (AST.expression * AST.expression) -> expression result = fun prev (k, v) ->
|
|
||||||
let%bind prev' = prev in
|
|
||||||
let%bind (k', v') =
|
|
||||||
let v' = e_a_some v ae.environment in
|
|
||||||
bind_map_pair (transpile_annotated_expression) (k , v') in
|
|
||||||
return @@ E_constant {cons_name=C_UPDATE;arguments=[k' ; v' ; prev']}
|
|
||||||
in
|
|
||||||
let init = return @@ E_make_empty_big_map (src, dst) in
|
|
||||||
List.fold_left aux init m
|
|
||||||
)
|
|
||||||
| E_look_up dsi -> (
|
|
||||||
let%bind (ds', i') = bind_map_pair f dsi in
|
|
||||||
return @@ E_constant {cons_name=C_MAP_FIND_OPT;arguments=[i' ; ds']}
|
|
||||||
)
|
|
||||||
| E_matching {matchee=expr; cases=m} -> (
|
| E_matching {matchee=expr; cases=m} -> (
|
||||||
let%bind expr' = transpile_annotated_expression expr in
|
let%bind expr' = transpile_annotated_expression expr in
|
||||||
match m with
|
match m with
|
||||||
|
@ -151,29 +151,41 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
|
|||||||
ok (e_a_empty_some s')
|
ok (e_a_empty_some s')
|
||||||
)
|
)
|
||||||
| TC_map (k_ty,v_ty)-> (
|
| TC_map (k_ty,v_ty)-> (
|
||||||
let%bind lst =
|
let%bind map =
|
||||||
trace_strong (wrong_mini_c_value "map" v) @@
|
trace_strong (wrong_mini_c_value "map" v) @@
|
||||||
get_map v in
|
get_map v in
|
||||||
let%bind lst' =
|
let%bind map' =
|
||||||
let aux = fun (k, v) ->
|
let aux = fun (k, v) ->
|
||||||
let%bind k' = untranspile k k_ty in
|
let%bind k' = untranspile k k_ty in
|
||||||
let%bind v' = untranspile v v_ty in
|
let%bind v' = untranspile v v_ty in
|
||||||
ok (k', v') in
|
ok (k', v') in
|
||||||
bind_map_list aux lst in
|
bind_map_list aux map in
|
||||||
return (E_map lst')
|
let map' = List.sort_uniq compare map' in
|
||||||
|
let aux = fun prev (k, v) ->
|
||||||
|
let (k', v') = (k , v ) in
|
||||||
|
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
|
||||||
|
in
|
||||||
|
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_right_list aux init map'
|
||||||
)
|
)
|
||||||
| TC_big_map (k_ty, v_ty) -> (
|
| TC_big_map (k_ty, v_ty) -> (
|
||||||
let%bind lst =
|
let%bind big_map =
|
||||||
trace_strong (wrong_mini_c_value "big_map" v) @@
|
trace_strong (wrong_mini_c_value "big_map" v) @@
|
||||||
get_big_map v in
|
get_big_map v in
|
||||||
let%bind lst' =
|
let%bind big_map' =
|
||||||
let aux = fun (k, v) ->
|
let aux = fun (k, v) ->
|
||||||
let%bind k' = untranspile k k_ty in
|
let%bind k' = untranspile k k_ty in
|
||||||
let%bind v' = untranspile v v_ty in
|
let%bind v' = untranspile v v_ty in
|
||||||
ok (k', v') in
|
ok (k', v') in
|
||||||
bind_map_list aux lst in
|
bind_map_list aux big_map in
|
||||||
return (E_big_map lst')
|
let big_map' = List.sort_uniq compare big_map' in
|
||||||
|
let aux = fun prev (k, v) ->
|
||||||
|
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
|
||||||
|
in
|
||||||
|
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_right_list aux init big_map'
|
||||||
)
|
)
|
||||||
|
| TC_map_or_big_map (_, _) -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c"
|
||||||
| TC_list ty -> (
|
| TC_list ty -> (
|
||||||
let%bind lst =
|
let%bind lst =
|
||||||
trace_strong (wrong_mini_c_value "list" v) @@
|
trace_strong (wrong_mini_c_value "list" v) @@
|
||||||
@ -181,7 +193,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
|
|||||||
let%bind lst' =
|
let%bind lst' =
|
||||||
let aux = fun e -> untranspile e ty in
|
let aux = fun e -> untranspile e ty in
|
||||||
bind_map_list aux lst in
|
bind_map_list aux lst in
|
||||||
return (E_list lst')
|
let aux = fun prev cur ->
|
||||||
|
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
|
||||||
|
let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_right_list aux init lst'
|
||||||
)
|
)
|
||||||
| TC_arrow _ -> (
|
| TC_arrow _ -> (
|
||||||
let%bind n =
|
let%bind n =
|
||||||
@ -196,7 +211,11 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
|
|||||||
let%bind lst' =
|
let%bind lst' =
|
||||||
let aux = fun e -> untranspile e ty in
|
let aux = fun e -> untranspile e ty in
|
||||||
bind_map_list aux lst in
|
bind_map_list aux lst in
|
||||||
return (E_set lst')
|
let lst' = List.sort_uniq compare lst' in
|
||||||
|
let aux = fun prev cur ->
|
||||||
|
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
|
||||||
|
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_list aux init lst'
|
||||||
)
|
)
|
||||||
| TC_contract _ ->
|
| TC_contract _ ->
|
||||||
fail @@ bad_untranspile "contract" v
|
fail @@ bad_untranspile "contract" v
|
||||||
|
@ -25,12 +25,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind init' = f init e in
|
let%bind init' = f init e in
|
||||||
match e.content with
|
match e.content with
|
||||||
| E_variable _ | E_skip | E_make_none _
|
| E_variable _ | E_skip | E_make_none _
|
||||||
| E_make_empty_map _
|
|
||||||
| E_make_empty_big_map _
|
|
||||||
| E_make_empty_list _
|
|
||||||
| E_make_empty_set _ -> (
|
|
||||||
ok init'
|
|
||||||
)
|
|
||||||
| E_literal _ -> ok init'
|
| E_literal _ -> ok init'
|
||||||
| E_constant (c) -> (
|
| E_constant (c) -> (
|
||||||
let%bind res = bind_fold_list self init' c.arguments in
|
let%bind res = bind_fold_list self init' c.arguments in
|
||||||
@ -94,10 +88,7 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
|||||||
let return content = ok { e' with content } in
|
let return content = ok { e' with content } in
|
||||||
match e'.content with
|
match e'.content with
|
||||||
| E_variable _ | E_literal _ | E_skip | E_make_none _
|
| E_variable _ | E_literal _ | E_skip | E_make_none _
|
||||||
| E_make_empty_map _
|
as em -> return em
|
||||||
| E_make_empty_big_map _
|
|
||||||
| E_make_empty_list _
|
|
||||||
| E_make_empty_set _ as em -> return em
|
|
||||||
| E_constant (c) -> (
|
| E_constant (c) -> (
|
||||||
let%bind lst = bind_map_list self c.arguments in
|
let%bind lst = bind_map_list self c.arguments in
|
||||||
return @@ E_constant {cons_name = c.cons_name; arguments = lst}
|
return @@ E_constant {cons_name = c.cons_name; arguments = lst}
|
||||||
|
@ -47,10 +47,6 @@ let rec is_pure : expression -> bool = fun e ->
|
|||||||
| E_closure _
|
| E_closure _
|
||||||
| E_skip
|
| E_skip
|
||||||
| E_variable _
|
| E_variable _
|
||||||
| E_make_empty_map _
|
|
||||||
| E_make_empty_big_map _
|
|
||||||
| E_make_empty_list _
|
|
||||||
| E_make_empty_set _
|
|
||||||
| E_make_none _
|
| E_make_none _
|
||||||
-> true
|
-> true
|
||||||
|
|
||||||
|
@ -40,10 +40,6 @@ let rec replace : expression -> var_name -> var_name -> expression =
|
|||||||
| E_variable z ->
|
| E_variable z ->
|
||||||
let z = replace_var z in
|
let z = replace_var z in
|
||||||
return @@ E_variable z
|
return @@ E_variable z
|
||||||
| E_make_empty_map _ -> e
|
|
||||||
| E_make_empty_big_map _ -> e
|
|
||||||
| E_make_empty_list _ -> e
|
|
||||||
| E_make_empty_set _ -> e
|
|
||||||
| E_make_none _ -> e
|
| E_make_none _ -> e
|
||||||
| E_iterator (name, ((v, tv), body), expr) ->
|
| E_iterator (name, ((v, tv), body), expr) ->
|
||||||
let body = replace body in
|
let body = replace body in
|
||||||
@ -175,10 +171,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
|
|||||||
)
|
)
|
||||||
(* All that follows is boilerplate *)
|
(* All that follows is boilerplate *)
|
||||||
| E_literal _ | E_skip | E_make_none _
|
| E_literal _ | E_skip | E_make_none _
|
||||||
| E_make_empty_map (_,_)
|
as em -> return em
|
||||||
| E_make_empty_big_map _
|
|
||||||
| E_make_empty_list _
|
|
||||||
| E_make_empty_set _ as em -> return em
|
|
||||||
| E_constant (c) -> (
|
| E_constant (c) -> (
|
||||||
let lst = List.map self c.arguments in
|
let lst = List.map self c.arguments in
|
||||||
return @@ E_constant {cons_name = c.cons_name; arguments = lst }
|
return @@ E_constant {cons_name = c.cons_name; arguments = lst }
|
||||||
|
@ -66,10 +66,25 @@ let rec get_operator : constant' -> type_value -> expression list -> predicate r
|
|||||||
let%bind m_ty = Compiler_type.type_ ty in
|
let%bind m_ty = Compiler_type.type_ ty in
|
||||||
ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT
|
ok @@ simple_unary @@ prim ~children:[m_ty] I_RIGHT
|
||||||
)
|
)
|
||||||
|
| C_LIST_EMPTY -> (
|
||||||
|
let%bind ty' = Mini_c.get_t_list ty in
|
||||||
|
let%bind m_ty = Compiler_type.type_ ty' in
|
||||||
|
ok @@ simple_constant @@ i_nil m_ty
|
||||||
|
)
|
||||||
| C_SET_EMPTY -> (
|
| C_SET_EMPTY -> (
|
||||||
let%bind ty' = Mini_c.get_t_set ty in
|
let%bind ty' = Mini_c.get_t_set ty in
|
||||||
let%bind m_ty = Compiler_type.type_ ty' in
|
let%bind m_ty = Compiler_type.type_ ty' in
|
||||||
ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET
|
ok @@ simple_constant @@ i_empty_set m_ty
|
||||||
|
)
|
||||||
|
| C_MAP_EMPTY -> (
|
||||||
|
let%bind sd = Mini_c.get_t_map ty in
|
||||||
|
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
|
||||||
|
ok @@ simple_constant @@ i_empty_map src dst
|
||||||
|
)
|
||||||
|
| C_BIG_MAP_EMPTY -> (
|
||||||
|
let%bind sd = Mini_c.get_t_big_map ty in
|
||||||
|
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
|
||||||
|
ok @@ simple_constant @@ i_empty_big_map src dst
|
||||||
)
|
)
|
||||||
| C_BYTES_UNPACK -> (
|
| C_BYTES_UNPACK -> (
|
||||||
let%bind ty' = Mini_c.get_t_option ty in
|
let%bind ty' = Mini_c.get_t_option ty in
|
||||||
@ -297,18 +312,6 @@ and translate_expression (expr:expression) (env:environment) : michelson result
|
|||||||
error title content in
|
error title content in
|
||||||
trace error @@
|
trace error @@
|
||||||
return code
|
return code
|
||||||
| E_make_empty_map sd ->
|
|
||||||
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
|
|
||||||
return @@ i_empty_map src dst
|
|
||||||
| E_make_empty_big_map sd ->
|
|
||||||
let%bind (src, dst) = bind_map_pair Compiler_type.type_ sd in
|
|
||||||
return @@ i_empty_big_map src dst
|
|
||||||
| E_make_empty_list t ->
|
|
||||||
let%bind t' = Compiler_type.type_ t in
|
|
||||||
return @@ i_nil t'
|
|
||||||
| E_make_empty_set t ->
|
|
||||||
let%bind t' = Compiler_type.type_ t in
|
|
||||||
return @@ i_empty_set t'
|
|
||||||
| E_make_none o ->
|
| E_make_none o ->
|
||||||
let%bind o' = Compiler_type.type_ o in
|
let%bind o' = Compiler_type.type_ o in
|
||||||
return @@ i_none o'
|
return @@ i_none o'
|
||||||
|
@ -154,6 +154,9 @@ 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)
|
||||||
@ -569,6 +572,9 @@ 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)
|
||||||
|
@ -55,6 +55,9 @@ 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)
|
||||||
@ -108,27 +111,41 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
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
|
||||||
return @@ O.E_record_update {record;path;update}
|
return @@ O.E_record_update {record;path;update}
|
||||||
| I.E_map map ->
|
| I.E_map map -> (
|
||||||
let%bind map = bind_map_list (
|
let map = List.sort_uniq compare map in
|
||||||
bind_map_pair compile_expression
|
let aux = fun prev (k, v) ->
|
||||||
) map
|
let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in
|
||||||
|
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
|
||||||
in
|
in
|
||||||
return @@ O.E_map map
|
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
|
||||||
| I.E_big_map big_map ->
|
bind_fold_right_list aux init map
|
||||||
let%bind big_map = bind_map_list (
|
)
|
||||||
bind_map_pair compile_expression
|
| I.E_big_map big_map -> (
|
||||||
) big_map
|
let big_map = List.sort_uniq compare big_map in
|
||||||
|
let aux = fun prev (k, v) ->
|
||||||
|
let%bind (k', v') = bind_map_pair (compile_expression) (k, v) in
|
||||||
|
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
|
||||||
in
|
in
|
||||||
return @@ O.E_big_map big_map
|
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_right_list aux init big_map
|
||||||
|
)
|
||||||
| I.E_list lst ->
|
| I.E_list lst ->
|
||||||
let%bind lst = bind_map_list compile_expression lst in
|
let%bind lst' = bind_map_list (compile_expression) lst in
|
||||||
return @@ O.E_list lst
|
let aux = fun prev cur ->
|
||||||
| I.E_set set ->
|
return @@ E_constant {cons_name=C_CONS;arguments=[cur ; prev]} in
|
||||||
let%bind set = bind_map_list compile_expression set in
|
let%bind init = return @@ E_constant {cons_name=C_LIST_EMPTY;arguments=[]} in
|
||||||
return @@ O.E_set set
|
bind_fold_right_list aux init lst'
|
||||||
|
| I.E_set set -> (
|
||||||
|
let%bind lst' = bind_map_list (compile_expression) set in
|
||||||
|
let lst' = List.sort_uniq compare lst' in
|
||||||
|
let aux = fun prev cur ->
|
||||||
|
return @@ E_constant {cons_name=C_SET_ADD;arguments=[cur ; prev]} in
|
||||||
|
let%bind init = return @@ E_constant {cons_name=C_SET_EMPTY;arguments=[]} in
|
||||||
|
bind_fold_list aux init lst'
|
||||||
|
)
|
||||||
| I.E_look_up look_up ->
|
| I.E_look_up look_up ->
|
||||||
let%bind look_up = bind_map_pair compile_expression look_up in
|
let%bind (path, index) = bind_map_pair compile_expression look_up in
|
||||||
return @@ O.E_look_up look_up
|
return @@ O.E_constant {cons_name=C_MAP_FIND_OPT;arguments=[index;path]}
|
||||||
| I.E_ascription {anno_expr; type_annotation} ->
|
| I.E_ascription {anno_expr; type_annotation} ->
|
||||||
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
|
||||||
@ -244,6 +261,9 @@ 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)
|
||||||
@ -301,27 +321,6 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
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_map map ->
|
|
||||||
let%bind map = bind_map_list (
|
|
||||||
bind_map_pair uncompile_expression
|
|
||||||
) map
|
|
||||||
in
|
|
||||||
return @@ I.E_map map
|
|
||||||
| O.E_big_map big_map ->
|
|
||||||
let%bind big_map = bind_map_list (
|
|
||||||
bind_map_pair uncompile_expression
|
|
||||||
) big_map
|
|
||||||
in
|
|
||||||
return @@ I.E_big_map big_map
|
|
||||||
| O.E_list lst ->
|
|
||||||
let%bind lst = bind_map_list uncompile_expression lst in
|
|
||||||
return @@ I.E_list lst
|
|
||||||
| O.E_set set ->
|
|
||||||
let%bind set = bind_map_list uncompile_expression set in
|
|
||||||
return @@ I.E_set set
|
|
||||||
| O.E_look_up look_up ->
|
|
||||||
let%bind look_up = bind_map_pair uncompile_expression look_up in
|
|
||||||
return @@ I.E_look_up look_up
|
|
||||||
| O.E_ascription {anno_expr; type_annotation} ->
|
| O.E_ascription {anno_expr; type_annotation} ->
|
||||||
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
|
||||||
|
@ -70,6 +70,7 @@ module Wrap = struct
|
|||||||
| TC_set s -> (C_set, [s])
|
| TC_set s -> (C_set, [s])
|
||||||
| TC_map ( k , v ) -> (C_map, [k;v])
|
| TC_map ( k , v ) -> (C_map, [k;v])
|
||||||
| TC_big_map ( k , v) -> (C_big_map, [k;v])
|
| TC_big_map ( k , v) -> (C_big_map, [k;v])
|
||||||
|
| TC_map_or_big_map ( k , v) -> (C_map, [k;v])
|
||||||
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
|
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
|
||||||
| TC_list l -> (C_list, [l])
|
| TC_list l -> (C_list, [l])
|
||||||
| TC_contract c -> (C_contract, [c])
|
| TC_contract c -> (C_contract, [c])
|
||||||
@ -103,6 +104,7 @@ module Wrap = struct
|
|||||||
| TC_set s -> (C_set , [s])
|
| TC_set s -> (C_set , [s])
|
||||||
| TC_map ( k , v ) -> (C_map , [k;v])
|
| TC_map ( k , v ) -> (C_map , [k;v])
|
||||||
| TC_big_map ( k , v ) -> (C_big_map, [k;v])
|
| TC_big_map ( k , v ) -> (C_big_map, [k;v])
|
||||||
|
| TC_map_or_big_map ( k , v) -> (C_map, [k;v])
|
||||||
| TC_contract c -> (C_contract, [c])
|
| TC_contract c -> (C_contract, [c])
|
||||||
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
|
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
|
||||||
)
|
)
|
||||||
|
@ -163,7 +163,6 @@ end
|
|||||||
|
|
||||||
open Errors
|
open Errors
|
||||||
|
|
||||||
let swap (a,b) = ok (b,a)
|
|
||||||
(*
|
(*
|
||||||
let rec type_program (p:I.program) : O.program result =
|
let rec type_program (p:I.program) : O.program result =
|
||||||
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
|
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
|
||||||
@ -346,6 +345,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
|
|||||||
let%bind k = evaluate_type e k in
|
let%bind k = evaluate_type e k in
|
||||||
let%bind v = evaluate_type e v in
|
let%bind v = evaluate_type e 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 = evaluate_type e k in
|
||||||
|
let%bind v = evaluate_type e v in
|
||||||
|
ok @@ O.TC_map_or_big_map (k,v)
|
||||||
| TC_contract c ->
|
| TC_contract c ->
|
||||||
let%bind c = evaluate_type e c in
|
let%bind c = evaluate_type e c in
|
||||||
ok @@ O.TC_contract c
|
ok @@ O.TC_contract c
|
||||||
@ -503,140 +506,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
|||||||
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
|
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
|
||||||
(* Data-structure *)
|
(* Data-structure *)
|
||||||
|
|
||||||
(*
|
|
||||||
| E_list lst ->
|
|
||||||
let%bind lst' = bind_map_list (type_expression e) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind init = match tv_opt with
|
|
||||||
| None -> ok None
|
|
||||||
| Some ty ->
|
|
||||||
let%bind ty' = get_t_list ty in
|
|
||||||
ok (Some ty') in
|
|
||||||
let%bind ty =
|
|
||||||
let%bind opt = bind_fold_list aux init
|
|
||||||
@@ List.map get_type_annotation lst' in
|
|
||||||
trace_option (needs_annotation ae "empty list") opt in
|
|
||||||
ok (t_list ty ())
|
|
||||||
in
|
|
||||||
return (E_list lst') tv
|
|
||||||
| E_set lst ->
|
|
||||||
let%bind lst' = bind_map_list (type_expression e) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind init = match tv_opt with
|
|
||||||
| None -> ok None
|
|
||||||
| Some ty ->
|
|
||||||
let%bind ty' = get_t_set ty in
|
|
||||||
ok (Some ty') in
|
|
||||||
let%bind ty =
|
|
||||||
let%bind opt = bind_fold_list aux init
|
|
||||||
@@ List.map get_type_annotation lst' in
|
|
||||||
trace_option (needs_annotation ae "empty set") opt in
|
|
||||||
ok (t_set ty ())
|
|
||||||
in
|
|
||||||
return (E_set lst') tv
|
|
||||||
| E_map lst ->
|
|
||||||
let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind key_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_annotation
|
|
||||||
@@ List.map fst lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_map_key tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
let%bind value_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_annotation
|
|
||||||
@@ List.map snd lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_map_value tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
ok (t_map key_type value_type ())
|
|
||||||
in
|
|
||||||
return (E_map lst') tv
|
|
||||||
*)
|
|
||||||
|
|
||||||
| E_list lst ->
|
|
||||||
let%bind (state', lst') =
|
|
||||||
bind_fold_map_list (fun state' elt -> type_expression e state' elt >>? swap) state lst in
|
|
||||||
let wrapped = Wrap.list (List.map (fun x -> O.(x.type_expression)) lst') in
|
|
||||||
return_wrapped (E_list lst') state' wrapped
|
|
||||||
| E_set set ->
|
|
||||||
let aux = fun state' elt -> type_expression e state' elt >>? swap in
|
|
||||||
let%bind (state', set') =
|
|
||||||
bind_fold_map_list aux state set in
|
|
||||||
let wrapped = Wrap.set (List.map (fun x -> O.(x.type_expression)) set') in
|
|
||||||
return_wrapped (E_set set') state' wrapped
|
|
||||||
| E_map map ->
|
|
||||||
let aux' state' elt = type_expression e state' elt >>? swap in
|
|
||||||
let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
|
|
||||||
let%bind (state', map') =
|
|
||||||
bind_fold_map_list aux state map in
|
|
||||||
let aux (x, y) = O.(x.type_expression , y.type_expression) in
|
|
||||||
let wrapped = Wrap.map (List.map aux map') in
|
|
||||||
return_wrapped (E_map map') state' wrapped
|
|
||||||
|
|
||||||
(* | E_big_map lst ->
|
|
||||||
* let%bind lst' = bind_map_list (bind_map_pair (type_expression e)) lst in
|
|
||||||
* let%bind tv =
|
|
||||||
* let aux opt c =
|
|
||||||
* match opt with
|
|
||||||
* | None -> ok (Some c)
|
|
||||||
* | Some c' ->
|
|
||||||
* let%bind _eq = Ast_typed.assert_type_value_eq (c, c') in
|
|
||||||
* ok (Some c') in
|
|
||||||
* let%bind key_type =
|
|
||||||
* let%bind sub =
|
|
||||||
* bind_fold_list aux None
|
|
||||||
* @@ List.map get_type_annotation
|
|
||||||
* @@ List.map fst lst' in
|
|
||||||
* let%bind annot = bind_map_option get_t_big_map_key tv_opt in
|
|
||||||
* trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
* O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
* in
|
|
||||||
* let%bind value_type =
|
|
||||||
* let%bind sub =
|
|
||||||
* bind_fold_list aux None
|
|
||||||
* @@ List.map get_type_annotation
|
|
||||||
* @@ List.map snd lst' in
|
|
||||||
* let%bind annot = bind_map_option get_t_big_map_value tv_opt in
|
|
||||||
* trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
* O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
* in
|
|
||||||
* ok (t_big_map key_type value_type ())
|
|
||||||
* in
|
|
||||||
* return (E_big_map lst') tv *)
|
|
||||||
| E_big_map big_map ->
|
|
||||||
let aux' state' elt = type_expression e state' elt >>? swap in
|
|
||||||
let aux = fun state' elt -> bind_fold_map_pair aux' state' elt in
|
|
||||||
let%bind (state', big_map') =
|
|
||||||
bind_fold_map_list aux state big_map in
|
|
||||||
let aux (x, y) = O.(x.type_expression , y.type_expression) in
|
|
||||||
let wrapped = Wrap.big_map (List.map aux big_map') in
|
|
||||||
return_wrapped (E_big_map big_map') state' wrapped
|
|
||||||
|
|
||||||
(* | E_lambda {
|
(* | E_lambda {
|
||||||
* binder ;
|
* binder ;
|
||||||
* input_type ;
|
* input_type ;
|
||||||
@ -685,17 +554,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
|||||||
let wrapped = Wrap.application f'.type_expression args.type_expression in
|
let wrapped = Wrap.application f'.type_expression args.type_expression in
|
||||||
return_wrapped (E_application {lamb=f';args}) state'' wrapped
|
return_wrapped (E_application {lamb=f';args}) state'' wrapped
|
||||||
|
|
||||||
(* | E_look_up dsi ->
|
|
||||||
* let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in
|
|
||||||
* let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in
|
|
||||||
* let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in
|
|
||||||
* return (E_look_up (ds , ind)) (t_option dst ()) *)
|
|
||||||
|
|
||||||
| E_look_up dsi ->
|
|
||||||
let aux' state' elt = type_expression e state' elt >>? swap in
|
|
||||||
let%bind (state'' , (ds , ind)) = bind_fold_map_pair aux' state dsi in
|
|
||||||
let wrapped = Wrap.look_up ds.type_expression ind.type_expression in
|
|
||||||
return_wrapped (E_look_up (ds , ind)) state'' wrapped
|
|
||||||
|
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
(* | E_matching (ex, m) -> (
|
(* | E_matching (ex, m) -> (
|
||||||
@ -983,6 +841,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
|
|||||||
let%bind k = untype_type_expression k in
|
let%bind k = untype_type_expression k in
|
||||||
let%bind v = untype_type_expression v in
|
let%bind v = untype_type_expression v in
|
||||||
ok @@ I.TC_big_map (k,v)
|
ok @@ I.TC_big_map (k,v)
|
||||||
|
| O.TC_map_or_big_map (k,v) ->
|
||||||
|
let%bind k = untype_type_expression k in
|
||||||
|
let%bind v = untype_type_expression v in
|
||||||
|
ok @@ I.TC_map_or_big_map (k,v)
|
||||||
| O.TC_arrow ( arg , ret ) ->
|
| O.TC_arrow ( arg , ret ) ->
|
||||||
let%bind arg' = untype_type_expression arg in
|
let%bind arg' = untype_type_expression arg in
|
||||||
let%bind ret' = untype_type_expression ret in
|
let%bind ret' = untype_type_expression ret in
|
||||||
@ -1064,21 +926,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
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_update r' l e)
|
||||||
| E_map m ->
|
|
||||||
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
|
|
||||||
return (e_map m')
|
|
||||||
| E_big_map m ->
|
|
||||||
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
|
|
||||||
return (e_big_map m')
|
|
||||||
| E_list lst ->
|
|
||||||
let%bind lst' = bind_map_list untype_expression lst in
|
|
||||||
return (e_list lst')
|
|
||||||
| E_set lst ->
|
|
||||||
let%bind lst' = bind_map_list untype_expression lst in
|
|
||||||
return (e_set lst')
|
|
||||||
| E_look_up dsi ->
|
|
||||||
let%bind (a , b) = bind_map_pair untype_expression dsi in
|
|
||||||
return (e_look_up a b)
|
|
||||||
| 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
|
||||||
|
@ -381,6 +381,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
|
|||||||
let%bind k = evaluate_type e k in
|
let%bind k = evaluate_type e k in
|
||||||
let%bind v = evaluate_type e v in
|
let%bind v = evaluate_type e 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 = evaluate_type e k in
|
||||||
|
let%bind v = evaluate_type e v in
|
||||||
|
ok @@ O.TC_map_or_big_map (k,v)
|
||||||
| TC_arrow ( arg , ret ) ->
|
| TC_arrow ( arg , ret ) ->
|
||||||
let%bind arg' = evaluate_type e arg in
|
let%bind arg' = evaluate_type e arg in
|
||||||
let%bind ret' = evaluate_type e ret in
|
let%bind ret' = evaluate_type e ret in
|
||||||
@ -511,108 +515,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
|
let%bind () = O.assert_type_expression_eq (tv, get_type_expression update) in
|
||||||
return (E_record_update {record; path; update}) wrapped
|
return (E_record_update {record; path; update}) wrapped
|
||||||
(* Data-structure *)
|
(* Data-structure *)
|
||||||
| E_list lst ->
|
|
||||||
let%bind lst' = bind_map_list (type_expression' e) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind init = match tv_opt with
|
|
||||||
| None -> ok None
|
|
||||||
| Some ty ->
|
|
||||||
let%bind ty' = get_t_list ty in
|
|
||||||
ok (Some ty') in
|
|
||||||
let%bind ty =
|
|
||||||
let%bind opt = bind_fold_list aux init
|
|
||||||
@@ List.map get_type_expression lst' in
|
|
||||||
trace_option (needs_annotation ae "empty list") opt in
|
|
||||||
ok (t_list ty ())
|
|
||||||
in
|
|
||||||
return (E_list lst') tv
|
|
||||||
| E_set lst ->
|
|
||||||
let%bind lst' = bind_map_list (type_expression' e) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind init = match tv_opt with
|
|
||||||
| None -> ok None
|
|
||||||
| Some ty ->
|
|
||||||
let%bind ty' = get_t_set ty in
|
|
||||||
ok (Some ty') in
|
|
||||||
let%bind ty =
|
|
||||||
let%bind opt = bind_fold_list aux init
|
|
||||||
@@ List.map get_type_expression lst' in
|
|
||||||
trace_option (needs_annotation ae "empty set") opt in
|
|
||||||
ok (t_set ty ())
|
|
||||||
in
|
|
||||||
return (E_set lst') tv
|
|
||||||
| E_map lst ->
|
|
||||||
let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind key_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_expression
|
|
||||||
@@ List.map fst lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_map_key tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
let%bind value_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_expression
|
|
||||||
@@ List.map snd lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_map_value tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
ok (t_map key_type value_type ())
|
|
||||||
in
|
|
||||||
return (E_map lst') tv
|
|
||||||
| E_big_map lst ->
|
|
||||||
let%bind lst' = bind_map_list (bind_map_pair (type_expression' e)) lst in
|
|
||||||
let%bind tv =
|
|
||||||
let aux opt c =
|
|
||||||
match opt with
|
|
||||||
| None -> ok (Some c)
|
|
||||||
| Some c' ->
|
|
||||||
let%bind _eq = Ast_typed.assert_type_expression_eq (c, c') in
|
|
||||||
ok (Some c') in
|
|
||||||
let%bind key_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_expression
|
|
||||||
@@ List.map fst lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_big_map_key tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
let%bind value_type =
|
|
||||||
let%bind sub =
|
|
||||||
bind_fold_list aux None
|
|
||||||
@@ List.map get_type_expression
|
|
||||||
@@ List.map snd lst' in
|
|
||||||
let%bind annot = bind_map_option get_t_big_map_value tv_opt in
|
|
||||||
trace (simple_info "empty map expression without a type annotation") @@
|
|
||||||
O.merge_annotation annot sub (needs_annotation ae "this map literal")
|
|
||||||
in
|
|
||||||
ok (t_big_map key_type value_type ())
|
|
||||||
in
|
|
||||||
return (E_big_map lst') tv
|
|
||||||
| E_lambda lambda ->
|
| E_lambda lambda ->
|
||||||
let%bind (lambda, lambda_type) = type_lambda e lambda in
|
let%bind (lambda, lambda_type) = type_lambda e lambda in
|
||||||
return (E_lambda lambda ) lambda_type
|
return (E_lambda lambda ) lambda_type
|
||||||
@ -682,6 +584,35 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
let%bind (name', tv) =
|
let%bind (name', tv) =
|
||||||
type_constant cons_name tv_lst tv_opt in
|
type_constant cons_name tv_lst tv_opt in
|
||||||
return (E_constant {cons_name=name';arguments=lst'}) tv
|
return (E_constant {cons_name=name';arguments=lst'}) tv
|
||||||
|
| E_constant {cons_name=C_SET_ADD|C_CONS as cst;arguments=[key;set]} ->
|
||||||
|
let%bind key' = type_expression' e key in
|
||||||
|
let tv_key = get_type_expression key' in
|
||||||
|
let tv = match tv_opt with
|
||||||
|
Some tv -> tv
|
||||||
|
| None -> match cst with
|
||||||
|
C_SET_ADD -> t_set tv_key ()
|
||||||
|
| C_CONS -> t_list tv_key ()
|
||||||
|
| _ -> failwith "Only C_SET_ADD and C_CONS are possible because those were the two cases matched above"
|
||||||
|
in
|
||||||
|
let%bind set' = type_expression' e ~tv_opt:tv set in
|
||||||
|
let tv_set = get_type_expression set' in
|
||||||
|
let tv_lst = [tv_key;tv_set] in
|
||||||
|
let%bind (name', tv) = type_constant cst tv_lst tv_opt in
|
||||||
|
return (E_constant {cons_name=name';arguments=[key';set']}) tv
|
||||||
|
| E_constant {cons_name=C_MAP_ADD as cst; arguments=[key;value;map]} ->
|
||||||
|
let%bind key' = type_expression' e key in
|
||||||
|
let%bind val' = type_expression' e value in
|
||||||
|
let tv_key = get_type_expression key' in
|
||||||
|
let tv_val = get_type_expression val' in
|
||||||
|
let tv = match tv_opt with
|
||||||
|
Some tv -> tv
|
||||||
|
| None -> t_map_or_big_map tv_key tv_val ()
|
||||||
|
in
|
||||||
|
let%bind map' = type_expression' e ~tv_opt:tv map in
|
||||||
|
let tv_map = get_type_expression map' in
|
||||||
|
let tv_lst = [tv_key;tv_val;tv_map] in
|
||||||
|
let%bind (name', tv) = type_constant cst tv_lst tv_opt in
|
||||||
|
return (E_constant {cons_name=name';arguments=[key';val';map']}) tv
|
||||||
| E_constant {cons_name;arguments} ->
|
| E_constant {cons_name;arguments} ->
|
||||||
let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
|
let%bind lst' = bind_list @@ List.map (type_expression' e) arguments in
|
||||||
let tv_lst = List.map get_type_expression lst' in
|
let tv_lst = List.map get_type_expression lst' in
|
||||||
@ -703,11 +634,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
lamb'.location
|
lamb'.location
|
||||||
in
|
in
|
||||||
return (E_application {lamb=lamb'; args=args'}) tv
|
return (E_application {lamb=lamb'; args=args'}) tv
|
||||||
| E_look_up dsi ->
|
|
||||||
let%bind (ds, ind) = bind_map_pair (type_expression' e) dsi in
|
|
||||||
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_expression in
|
|
||||||
let%bind _ = O.assert_type_expression_eq (ind.type_expression, src) in
|
|
||||||
return (E_look_up (ds , ind)) (t_option dst ())
|
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_matching {matchee;cases} -> (
|
| E_matching {matchee;cases} -> (
|
||||||
let%bind ex' = type_expression' e matchee in
|
let%bind ex' = type_expression' e matchee in
|
||||||
@ -870,21 +796,6 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
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_update r' l e)
|
||||||
| E_map m ->
|
|
||||||
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
|
|
||||||
return (e_map m')
|
|
||||||
| E_big_map m ->
|
|
||||||
let%bind m' = bind_map_list (bind_map_pair untype_expression) m in
|
|
||||||
return (e_big_map m')
|
|
||||||
| E_list lst ->
|
|
||||||
let%bind lst' = bind_map_list untype_expression lst in
|
|
||||||
return (e_list lst')
|
|
||||||
| E_set lst ->
|
|
||||||
let%bind lst' = bind_map_list untype_expression lst in
|
|
||||||
return (e_set lst')
|
|
||||||
| E_look_up dsi ->
|
|
||||||
let%bind (a , b) = bind_map_pair untype_expression dsi in
|
|
||||||
return (e_look_up a b)
|
|
||||||
| 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
|
||||||
|
@ -8,17 +8,10 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind init' = f init e in
|
let%bind init' = f init e in
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
| E_literal _ | E_variable _ -> ok init'
|
| E_literal _ | E_variable _ -> ok init'
|
||||||
| E_list lst | E_set lst | E_constant {arguments=lst} -> (
|
| E_constant {arguments=lst} -> (
|
||||||
let%bind res = bind_fold_list self init' lst in
|
let%bind res = bind_fold_list self init' lst in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_map lst | E_big_map lst -> (
|
|
||||||
let%bind res = bind_fold_list (bind_fold_pair self) init' lst in
|
|
||||||
ok res
|
|
||||||
)
|
|
||||||
| E_look_up ab ->
|
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
|
||||||
ok res
|
|
||||||
| E_application {lamb; args} -> (
|
| E_application {lamb; args} -> (
|
||||||
let ab = (lamb, args) in
|
let ab = (lamb, args) in
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
let%bind res = bind_fold_pair self init' ab in
|
||||||
@ -93,26 +86,6 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
|||||||
let%bind e' = f e in
|
let%bind e' = f e in
|
||||||
let return expression_content = ok { e' with expression_content } in
|
let return expression_content = ok { e' with expression_content } in
|
||||||
match e'.expression_content with
|
match e'.expression_content with
|
||||||
| E_list lst -> (
|
|
||||||
let%bind lst' = bind_map_list self lst in
|
|
||||||
return @@ E_list lst'
|
|
||||||
)
|
|
||||||
| E_set lst -> (
|
|
||||||
let%bind lst' = bind_map_list self lst in
|
|
||||||
return @@ E_set lst'
|
|
||||||
)
|
|
||||||
| E_map lst -> (
|
|
||||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
|
||||||
return @@ E_map lst'
|
|
||||||
)
|
|
||||||
| E_big_map lst -> (
|
|
||||||
let%bind lst' = bind_map_list (bind_map_pair self) lst in
|
|
||||||
return @@ E_big_map lst'
|
|
||||||
)
|
|
||||||
| E_look_up ab -> (
|
|
||||||
let%bind ab' = bind_map_pair self ab in
|
|
||||||
return @@ E_look_up ab'
|
|
||||||
)
|
|
||||||
| E_matching {matchee=e;cases} -> (
|
| E_matching {matchee=e;cases} -> (
|
||||||
let%bind e' = self e in
|
let%bind e' = self e in
|
||||||
let%bind cases' = map_cases f cases in
|
let%bind cases' = map_cases f cases in
|
||||||
@ -208,26 +181,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
else
|
else
|
||||||
let return expression_content = { e' with expression_content } in
|
let return expression_content = { e' with expression_content } in
|
||||||
match e'.expression_content with
|
match e'.expression_content with
|
||||||
| E_list lst -> (
|
|
||||||
let%bind (res, lst') = bind_fold_map_list self init' lst in
|
|
||||||
ok (res, return @@ E_list lst')
|
|
||||||
)
|
|
||||||
| E_set lst -> (
|
|
||||||
let%bind (res, lst') = bind_fold_map_list self init' lst in
|
|
||||||
ok (res, return @@ E_set lst')
|
|
||||||
)
|
|
||||||
| E_map lst -> (
|
|
||||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
|
||||||
ok (res, return @@ E_map lst')
|
|
||||||
)
|
|
||||||
| E_big_map lst -> (
|
|
||||||
let%bind (res, lst') = bind_fold_map_list (bind_fold_map_pair self) init' lst in
|
|
||||||
ok (res, return @@ E_big_map lst')
|
|
||||||
)
|
|
||||||
| E_look_up ab -> (
|
|
||||||
let%bind (res, ab') = bind_fold_map_pair self init' ab in
|
|
||||||
ok (res, return @@ E_look_up ab')
|
|
||||||
)
|
|
||||||
| E_matching {matchee=e;cases} -> (
|
| E_matching {matchee=e;cases} -> (
|
||||||
let%bind (res, e') = self init' e in
|
let%bind (res, e') = self init' e in
|
||||||
let%bind (res,cases') = fold_map_cases f res cases in
|
let%bind (res,cases') = fold_map_cases f res cases in
|
||||||
|
@ -21,6 +21,10 @@ let rec check_no_nested_bigmap is_in_bigmap e =
|
|||||||
let%bind _ = check_no_nested_bigmap false key in
|
let%bind _ = check_no_nested_bigmap false key in
|
||||||
let%bind _ = check_no_nested_bigmap true value in
|
let%bind _ = check_no_nested_bigmap true value in
|
||||||
ok ()
|
ok ()
|
||||||
|
| T_operator (TC_map_or_big_map (key, value)) ->
|
||||||
|
let%bind _ = check_no_nested_bigmap false key in
|
||||||
|
let%bind _ = check_no_nested_bigmap true value in
|
||||||
|
ok ()
|
||||||
| T_operator (TC_contract t)
|
| T_operator (TC_contract t)
|
||||||
| T_operator (TC_option t)
|
| T_operator (TC_option t)
|
||||||
| T_operator (TC_list t)
|
| T_operator (TC_list t)
|
||||||
|
@ -56,21 +56,6 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit
|
|||||||
let%bind _ = check_recursive_call n false record in
|
let%bind _ = check_recursive_call n false record in
|
||||||
let%bind _ = check_recursive_call n false update in
|
let%bind _ = check_recursive_call n false update in
|
||||||
ok ()
|
ok ()
|
||||||
| E_map eel | E_big_map eel->
|
|
||||||
let aux (e1,e2) =
|
|
||||||
let%bind _ = check_recursive_call n false e1 in
|
|
||||||
let%bind _ = check_recursive_call n false e2 in
|
|
||||||
ok ()
|
|
||||||
in
|
|
||||||
let%bind _ = bind_map_list aux eel in
|
|
||||||
ok ()
|
|
||||||
| E_list el | E_set el ->
|
|
||||||
let%bind _ = bind_map_list (check_recursive_call n false) el in
|
|
||||||
ok ()
|
|
||||||
| E_look_up (e1,e2) ->
|
|
||||||
let%bind _ = check_recursive_call n false e1 in
|
|
||||||
let%bind _ = check_recursive_call n false e2 in
|
|
||||||
ok ()
|
|
||||||
|
|
||||||
and check_recursive_call_in_matching = fun n final_path c ->
|
and check_recursive_call_in_matching = fun n final_path c ->
|
||||||
match c with
|
match c with
|
||||||
|
@ -621,6 +621,20 @@ module Typer = struct
|
|||||||
let%bind () = assert_type_expression_eq (src , k) in
|
let%bind () = assert_type_expression_eq (src , k) in
|
||||||
ok m
|
ok m
|
||||||
|
|
||||||
|
let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt ->
|
||||||
|
match tv_opt with
|
||||||
|
| None -> simple_fail "untyped MAP_EMPTY"
|
||||||
|
| Some t ->
|
||||||
|
let%bind (src, dst) = get_t_map t in
|
||||||
|
ok @@ t_map src dst ()
|
||||||
|
|
||||||
|
let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt ->
|
||||||
|
match tv_opt with
|
||||||
|
| None -> simple_fail "untyped BIG_MAP_EMPTY"
|
||||||
|
| Some t ->
|
||||||
|
let%bind (src, dst) = get_t_big_map t in
|
||||||
|
ok @@ t_big_map src dst ()
|
||||||
|
|
||||||
let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
|
let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m ->
|
||||||
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
|
let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in
|
||||||
let%bind () = assert_type_expression_eq (src, k) in
|
let%bind () = assert_type_expression_eq (src, k) in
|
||||||
@ -949,6 +963,11 @@ module Typer = struct
|
|||||||
then ok (t_unit ())
|
then ok (t_unit ())
|
||||||
else fail @@ Operator_errors.type_error "bad set iter" key arg ()
|
else fail @@ Operator_errors.type_error "bad set iter" key arg ()
|
||||||
|
|
||||||
|
let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt ->
|
||||||
|
match tv_opt with
|
||||||
|
| None -> simple_fail "untyped LIST_EMPTY"
|
||||||
|
| Some t -> ok t
|
||||||
|
|
||||||
let list_iter = typer_2 "LIST_ITER" @@ fun body lst ->
|
let list_iter = typer_2 "LIST_ITER" @@ fun body lst ->
|
||||||
let%bind (arg , res) = get_t_function body in
|
let%bind (arg , res) = get_t_function body in
|
||||||
let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in
|
let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in
|
||||||
@ -1145,7 +1164,6 @@ module Typer = struct
|
|||||||
| C_SLICE -> ok @@ slice ;
|
| C_SLICE -> ok @@ slice ;
|
||||||
| C_BYTES_PACK -> ok @@ bytes_pack ;
|
| C_BYTES_PACK -> ok @@ bytes_pack ;
|
||||||
| C_BYTES_UNPACK -> ok @@ bytes_unpack ;
|
| C_BYTES_UNPACK -> ok @@ bytes_unpack ;
|
||||||
| C_CONS -> ok @@ cons ;
|
|
||||||
(* SET *)
|
(* SET *)
|
||||||
| C_SET_EMPTY -> ok @@ set_empty ;
|
| C_SET_EMPTY -> ok @@ set_empty ;
|
||||||
| C_SET_ADD -> ok @@ set_add ;
|
| C_SET_ADD -> ok @@ set_add ;
|
||||||
@ -1155,10 +1173,14 @@ module Typer = struct
|
|||||||
| C_SET_MEM -> ok @@ set_mem ;
|
| C_SET_MEM -> ok @@ set_mem ;
|
||||||
|
|
||||||
(* LIST *)
|
(* LIST *)
|
||||||
|
| C_CONS -> ok @@ cons ;
|
||||||
|
| C_LIST_EMPTY -> ok @@ list_empty ;
|
||||||
| C_LIST_ITER -> ok @@ list_iter ;
|
| C_LIST_ITER -> ok @@ list_iter ;
|
||||||
| C_LIST_MAP -> ok @@ list_map ;
|
| C_LIST_MAP -> ok @@ list_map ;
|
||||||
| C_LIST_FOLD -> ok @@ list_fold ;
|
| C_LIST_FOLD -> ok @@ list_fold ;
|
||||||
(* MAP *)
|
(* MAP *)
|
||||||
|
| C_MAP_EMPTY -> ok @@ map_empty ;
|
||||||
|
| C_BIG_MAP_EMPTY -> ok @@ big_map_empty ;
|
||||||
| C_MAP_ADD -> ok @@ map_add ;
|
| C_MAP_ADD -> ok @@ map_add ;
|
||||||
| C_MAP_REMOVE -> ok @@ map_remove ;
|
| C_MAP_REMOVE -> ok @@ map_remove ;
|
||||||
| C_MAP_UPDATE -> ok @@ map_update ;
|
| C_MAP_UPDATE -> ok @@ map_update ;
|
||||||
|
@ -168,8 +168,9 @@ let e_typed_none ?loc t_opt =
|
|||||||
let type_annotation = t_option t_opt in
|
let type_annotation = t_option t_opt in
|
||||||
e_annotation ?loc (e_none ?loc ()) type_annotation
|
e_annotation ?loc (e_none ?loc ()) type_annotation
|
||||||
|
|
||||||
let e_typed_list ?loc lst t =
|
let e_typed_list ?loc lst t = e_annotation ?loc (e_list lst) (t_list t)
|
||||||
e_annotation ?loc (e_list lst) (t_list t)
|
let e_typed_list_literal ?loc lst t =
|
||||||
|
e_annotation ?loc (e_constant C_LIST_LITERAL lst) (t_list t)
|
||||||
|
|
||||||
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
|
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
|
||||||
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
|
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
|
||||||
|
@ -100,6 +100,7 @@ val make_option_typed : ?loc:Location.t -> expression -> type_expression option
|
|||||||
val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
||||||
|
|
||||||
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
|
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
|
||||||
|
val e_typed_list_literal : ?loc:Location.t -> expression list -> type_expression -> expression
|
||||||
|
|
||||||
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
||||||
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
||||||
|
@ -31,16 +31,6 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
fprintf ppf "%a.%a" expression ra.record label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.label
|
||||||
| 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 ->
|
|
||||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
|
||||||
| E_big_map m ->
|
|
||||||
fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
|
|
||||||
| E_list lst ->
|
|
||||||
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
|
||||||
| E_set lst ->
|
|
||||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
|
||||||
| E_look_up (ds, ind) ->
|
|
||||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
|
||||||
| 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
|
||||||
|
@ -107,14 +107,10 @@ let e_bytes_raw ?loc (b: bytes) : expression =
|
|||||||
make_expr ?loc @@ E_literal (Literal_bytes b)
|
make_expr ?loc @@ E_literal (Literal_bytes b)
|
||||||
let e_bytes_string ?loc (s: string) : expression =
|
let e_bytes_string ?loc (s: string) : expression =
|
||||||
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
|
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
|
||||||
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
|
|
||||||
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
|
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
|
||||||
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
|
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
|
||||||
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
|
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
|
||||||
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
|
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
|
||||||
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
|
|
||||||
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
|
|
||||||
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})
|
||||||
@ -127,7 +123,6 @@ let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr;
|
|||||||
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
||||||
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
|
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
|
||||||
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
|
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
|
||||||
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
|
|
||||||
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
|
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
|
||||||
(*
|
(*
|
||||||
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*)
|
||||||
@ -161,15 +156,6 @@ let e_typed_none ?loc t_opt =
|
|||||||
let type_annotation = t_option t_opt in
|
let type_annotation = t_option t_opt in
|
||||||
e_annotation ?loc (e_none ?loc ()) type_annotation
|
e_annotation ?loc (e_none ?loc ()) type_annotation
|
||||||
|
|
||||||
let e_typed_list ?loc lst t =
|
|
||||||
e_annotation ?loc (e_list lst) (t_list t)
|
|
||||||
|
|
||||||
let e_typed_map ?loc lst k v = e_annotation ?loc (e_map lst) (t_map k v)
|
|
||||||
let e_typed_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v)
|
|
||||||
|
|
||||||
let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
|
|
||||||
|
|
||||||
|
|
||||||
let e_lambda ?loc (binder : expression_variable)
|
let e_lambda ?loc (binder : expression_variable)
|
||||||
(input_type : type_expression option)
|
(input_type : type_expression option)
|
||||||
(output_type : type_expression option)
|
(output_type : type_expression option)
|
||||||
@ -221,9 +207,16 @@ let get_e_pair = fun t ->
|
|||||||
| _ -> simple_fail "not a pair"
|
| _ -> simple_fail "not a pair"
|
||||||
|
|
||||||
let get_e_list = fun t ->
|
let get_e_list = fun t ->
|
||||||
|
let rec aux t =
|
||||||
match t with
|
match t with
|
||||||
| E_list lst -> ok lst
|
E_constant {cons_name=C_CONS;arguments=[key;lst]} ->
|
||||||
|
let%bind lst = aux lst.expression_content in
|
||||||
|
ok @@ key::(lst)
|
||||||
|
| E_constant {cons_name=C_LIST_EMPTY;arguments=[]} ->
|
||||||
|
ok @@ []
|
||||||
| _ -> simple_fail "not a list"
|
| _ -> simple_fail "not a list"
|
||||||
|
in
|
||||||
|
aux t
|
||||||
|
|
||||||
let tuple_of_record (m: _ LMap.t) =
|
let tuple_of_record (m: _ LMap.t) =
|
||||||
let aux i =
|
let aux i =
|
||||||
@ -250,17 +243,18 @@ let extract_pair : expression -> (expression * expression) result = fun e ->
|
|||||||
)
|
)
|
||||||
| _ -> fail @@ bad_kind "pair" e.location
|
| _ -> fail @@ bad_kind "pair" e.location
|
||||||
|
|
||||||
let extract_list : expression -> (expression list) result = fun e ->
|
|
||||||
match e.expression_content with
|
|
||||||
| E_list lst -> ok lst
|
|
||||||
| _ -> fail @@ bad_kind "list" e.location
|
|
||||||
|
|
||||||
let extract_record : expression -> (label * expression) list result = fun e ->
|
let extract_record : expression -> (label * expression) list result = fun e ->
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
| E_record lst -> ok @@ LMap.to_kv_list lst
|
| E_record lst -> ok @@ LMap.to_kv_list lst
|
||||||
| _ -> fail @@ bad_kind "record" e.location
|
| _ -> fail @@ bad_kind "record" e.location
|
||||||
|
|
||||||
let extract_map : expression -> (expression * expression) list result = fun e ->
|
let extract_map : expression -> (expression * expression) list result = fun e ->
|
||||||
|
let rec aux e =
|
||||||
match e.expression_content with
|
match e.expression_content with
|
||||||
| E_map lst -> ok lst
|
E_constant {cons_name=C_UPDATE|C_MAP_ADD; arguments=[k;v;map]} ->
|
||||||
|
let%bind map = aux map in
|
||||||
|
ok @@ (k,v)::map
|
||||||
|
| E_constant {cons_name=C_MAP_EMPTY|C_BIG_MAP_EMPTY; arguments=[]} -> ok @@ []
|
||||||
| _ -> fail @@ bad_kind "map" e.location
|
| _ -> fail @@ bad_kind "map" e.location
|
||||||
|
in
|
||||||
|
aux e
|
||||||
|
@ -65,7 +65,6 @@ val e'_bytes : string -> expression_content result
|
|||||||
val e_bytes_hex : ?loc:Location.t -> string -> expression result
|
val e_bytes_hex : ?loc:Location.t -> string -> expression result
|
||||||
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
|
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
|
||||||
val e_bytes_string : ?loc:Location.t -> string -> expression
|
val e_bytes_string : ?loc:Location.t -> string -> expression
|
||||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
|
||||||
|
|
||||||
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
|
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
|
||||||
val e_tuple : ?loc:Location.t -> expression list -> expression
|
val e_tuple : ?loc:Location.t -> expression list -> expression
|
||||||
@ -73,9 +72,6 @@ val e_some : ?loc:Location.t -> expression -> expression
|
|||||||
val e_none : ?loc:Location.t -> unit -> expression
|
val e_none : ?loc:Location.t -> unit -> expression
|
||||||
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
|
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
|
||||||
val e_set : ?loc:Location.t -> expression list -> expression
|
|
||||||
val e_list : ?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 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
|
||||||
@ -89,7 +85,6 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio
|
|||||||
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
|
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
|
||||||
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
|
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
|
||||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
|
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
|
||||||
|
|
||||||
@ -97,13 +92,6 @@ val make_option_typed : ?loc:Location.t -> expression -> type_expression option
|
|||||||
|
|
||||||
val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
val e_typed_none : ?loc:Location.t -> type_expression -> expression
|
||||||
|
|
||||||
val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expression
|
|
||||||
|
|
||||||
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
|
||||||
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
|
||||||
|
|
||||||
val e_typed_set : ?loc:Location.t -> expression list -> 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
|
||||||
@ -126,8 +114,6 @@ val is_e_failwith : expression -> bool
|
|||||||
*)
|
*)
|
||||||
val extract_pair : expression -> ( expression * expression ) result
|
val extract_pair : expression -> ( expression * expression ) result
|
||||||
|
|
||||||
val extract_list : expression -> (expression list) result
|
|
||||||
|
|
||||||
val extract_record : expression -> (label * expression) list result
|
val extract_record : expression -> (label * expression) list result
|
||||||
|
|
||||||
val extract_map : expression -> (expression * expression) list result
|
val extract_map : expression -> (expression * expression) list result
|
||||||
|
@ -139,51 +139,12 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
ok ()
|
ok ()
|
||||||
| E_record_update _, _ ->
|
| E_record_update _, _ ->
|
||||||
simple_fail "comparing record update with other expression"
|
simple_fail "comparing record update with other expression"
|
||||||
|
|
||||||
| (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")
|
|
||||||
(fun () ->
|
|
||||||
let lsta' = List.sort compare lsta in
|
|
||||||
let lstb' = List.sort compare lstb in
|
|
||||||
List.combine lsta' lstb') in
|
|
||||||
let aux = fun ((ka, va), (kb, vb)) ->
|
|
||||||
let%bind _ = assert_value_eq (ka, kb) in
|
|
||||||
let%bind _ = assert_value_eq (va, vb) in
|
|
||||||
ok () in
|
|
||||||
let%bind _all = bind_map_list aux lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| (E_map _ | E_big_map _), _ ->
|
|
||||||
simple_fail "comparing map with other expression"
|
|
||||||
|
|
||||||
| E_list lsta, E_list lstb -> (
|
|
||||||
let%bind lst =
|
|
||||||
generic_try (simple_error "list of different lengths")
|
|
||||||
(fun () -> List.combine lsta lstb) in
|
|
||||||
let%bind _all = bind_map_list assert_value_eq lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| E_list _, _ ->
|
|
||||||
simple_fail "comparing list with other expression"
|
|
||||||
|
|
||||||
| E_set lsta, E_set lstb -> (
|
|
||||||
let lsta' = List.sort (compare) lsta in
|
|
||||||
let lstb' = List.sort (compare) lstb in
|
|
||||||
let%bind lst =
|
|
||||||
generic_try (simple_error "set of different lengths")
|
|
||||||
(fun () -> List.combine lsta' lstb') in
|
|
||||||
let%bind _all = bind_map_list assert_value_eq lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| E_set _, _ ->
|
|
||||||
simple_fail "comparing set with other expression"
|
|
||||||
|
|
||||||
| (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
|
| (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b)
|
||||||
| (_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_record_accessor _, _)
|
||||||
| (E_look_up _, _) | (E_matching _, _)
|
| (E_matching _, _)
|
||||||
-> simple_fail "comparing not a value"
|
-> 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)
|
||||||
|
@ -43,13 +43,6 @@ and expression_content =
|
|||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of accessor
|
||||||
| E_record_update of update
|
| E_record_update of update
|
||||||
(* Data Structures *)
|
|
||||||
(* TODO : move to constant*)
|
|
||||||
| E_map of (expression * expression) list (*move to operator *)
|
|
||||||
| E_big_map of (expression * expression) list (*move to operator *)
|
|
||||||
| E_list of expression list
|
|
||||||
| E_set of expression list
|
|
||||||
| E_look_up of (expression * expression)
|
|
||||||
(* Advanced *)
|
(* Advanced *)
|
||||||
| E_ascription of ascription
|
| E_ascription of ascription
|
||||||
|
|
||||||
|
@ -32,16 +32,6 @@ and expression_content ppf (ec: expression_content) =
|
|||||||
fprintf ppf "%a.%a" expression ra.record label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.label
|
||||||
| 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 ->
|
|
||||||
fprintf ppf "map[%a]" (list_sep_d assoc_expression) m
|
|
||||||
| E_big_map m ->
|
|
||||||
fprintf ppf "big_map[%a]" (list_sep_d assoc_expression) m
|
|
||||||
| E_list lst ->
|
|
||||||
fprintf ppf "list[%a]" (list_sep_d expression) lst
|
|
||||||
| E_set lst ->
|
|
||||||
fprintf ppf "set[%a]" (list_sep_d expression) lst
|
|
||||||
| E_look_up (ds, ind) ->
|
|
||||||
fprintf ppf "(%a)[%a]" expression ds expression ind
|
|
||||||
| E_lambda {binder; result} ->
|
| E_lambda {binder; result} ->
|
||||||
fprintf ppf "lambda (%a) return %a" expression_variable binder
|
fprintf ppf "lambda (%a) return %a" expression_variable binder
|
||||||
expression result
|
expression result
|
||||||
|
@ -64,6 +64,7 @@ let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label "
|
|||||||
|
|
||||||
let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
|
let t_map key value ?s () = make_t (T_operator (TC_map (key , value))) s
|
||||||
let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
|
let t_big_map key value ?s () = make_t (T_operator (TC_big_map (key , value))) s
|
||||||
|
let t_map_or_big_map key value ?s () = make_t (T_operator (TC_map_or_big_map (key,value))) s
|
||||||
|
|
||||||
let t_sum m ?s () : type_expression = make_t (T_sum m) s
|
let t_sum m ?s () : type_expression = make_t (T_sum m) s
|
||||||
let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
|
let make_t_ez_sum (lst:(constructor' * type_expression) list) : type_expression =
|
||||||
@ -190,11 +191,13 @@ let get_t_record (t:type_expression) : type_expression label_map result = match
|
|||||||
let get_t_map (t:type_expression) : (type_expression * type_expression) result =
|
let get_t_map (t:type_expression) : (type_expression * type_expression) result =
|
||||||
match t.type_content with
|
match t.type_content with
|
||||||
| T_operator (TC_map (k,v)) -> ok (k, v)
|
| T_operator (TC_map (k,v)) -> ok (k, v)
|
||||||
|
| T_operator (TC_map_or_big_map (k,v)) -> ok (k, v)
|
||||||
| _ -> fail @@ Errors.not_a_x_type "map" t ()
|
| _ -> fail @@ Errors.not_a_x_type "map" t ()
|
||||||
|
|
||||||
let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
|
let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
|
||||||
match t.type_content with
|
match t.type_content with
|
||||||
| T_operator (TC_big_map (k,v)) -> ok (k, v)
|
| T_operator (TC_big_map (k,v)) -> ok (k, v)
|
||||||
|
| T_operator (TC_map_or_big_map (k,v)) -> ok (k, v)
|
||||||
| _ -> fail @@ Errors.not_a_x_type "big_map" t ()
|
| _ -> fail @@ Errors.not_a_x_type "big_map" t ()
|
||||||
|
|
||||||
let get_t_map_key : type_expression -> type_expression result = fun t ->
|
let get_t_map_key : type_expression -> type_expression result = fun t ->
|
||||||
@ -276,8 +279,6 @@ let ez_e_record (lst : (label * expression) list) : expression_content =
|
|||||||
let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
|
let e_some s : expression_content = E_constant {cons_name=C_SOME;arguments=[s]}
|
||||||
let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]}
|
let e_none (): expression_content = E_constant {cons_name=C_NONE; arguments=[]}
|
||||||
|
|
||||||
let e_map lst : expression_content = E_map lst
|
|
||||||
|
|
||||||
let e_unit () : expression_content = E_literal (Literal_unit)
|
let e_unit () : expression_content = E_literal (Literal_unit)
|
||||||
let e_int n : expression_content = E_literal (Literal_int n)
|
let e_int n : expression_content = E_literal (Literal_int n)
|
||||||
let e_nat n : expression_content = E_literal (Literal_nat n)
|
let e_nat n : expression_content = E_literal (Literal_nat n)
|
||||||
@ -296,7 +297,6 @@ let e_lambda l : expression_content = E_lambda l
|
|||||||
let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
|
let e_pair a b : expression_content = ez_e_record [(Label "0",a);(Label "1", b)]
|
||||||
let e_application lamb args : expression_content = E_application {lamb;args}
|
let e_application lamb args : expression_content = E_application {lamb;args}
|
||||||
let e_variable v : expression_content = E_variable v
|
let e_variable v : expression_content = E_variable v
|
||||||
let e_list lst : expression_content = E_list lst
|
|
||||||
let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
|
let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; let_result; inline }
|
||||||
|
|
||||||
let e_a_unit = make_a_e (e_unit ()) (t_unit ())
|
let e_a_unit = make_a_e (e_unit ()) (t_unit ())
|
||||||
@ -314,8 +314,6 @@ let e_a_record r = make_a_e (e_record r) (t_record (LMap.map get_type_expression
|
|||||||
let e_a_application a b = make_a_e (e_application a b) (get_type_expression b)
|
let e_a_application a b = make_a_e (e_application a b) (get_type_expression b)
|
||||||
let e_a_variable v ty = make_a_e (e_variable v) ty
|
let e_a_variable v ty = make_a_e (e_variable v) ty
|
||||||
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
|
let ez_e_a_record r = make_a_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, y.type_expression) r) ())
|
||||||
let e_a_map lst k v = make_a_e (e_map lst) (t_map k v ())
|
|
||||||
let e_a_list lst t = make_a_e (e_list lst) (t_list t ())
|
|
||||||
let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body)
|
let e_a_let_in binder expr body attributes = make_a_e (e_let_in binder expr body attributes) (get_type_expression body)
|
||||||
|
|
||||||
|
|
||||||
|
@ -31,6 +31,7 @@ val ez_t_record : ( label * type_expression ) list -> ?s:S.type_expression -> un
|
|||||||
|
|
||||||
val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
val t_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
||||||
val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
val t_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
||||||
|
val t_map_or_big_map : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
||||||
val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
|
val t_sum : type_expression constructor_map -> ?s:S.type_expression -> unit -> type_expression
|
||||||
val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
|
val make_t_ez_sum : ( constructor' * type_expression ) list -> type_expression
|
||||||
val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
val t_function : type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression
|
||||||
@ -109,7 +110,6 @@ val ez_e_record : ( string * expression ) list -> expression
|
|||||||
*)
|
*)
|
||||||
val e_some : expression -> expression_content
|
val e_some : expression -> expression_content
|
||||||
val e_none : unit -> expression_content
|
val e_none : unit -> expression_content
|
||||||
val e_map : ( expression * expression ) list -> expression_content
|
|
||||||
val e_unit : unit -> expression_content
|
val e_unit : unit -> expression_content
|
||||||
val e_int : int -> expression_content
|
val e_int : int -> expression_content
|
||||||
val e_nat : int -> expression_content
|
val e_nat : int -> expression_content
|
||||||
@ -128,7 +128,6 @@ val e_lambda : lambda -> expression_content
|
|||||||
val e_pair : expression -> expression -> expression_content
|
val e_pair : expression -> expression -> expression_content
|
||||||
val e_application : expression -> expr -> expression_content
|
val e_application : expression -> expr -> expression_content
|
||||||
val e_variable : expression_variable -> expression_content
|
val e_variable : expression_variable -> expression_content
|
||||||
val e_list : expression list -> expression_content
|
|
||||||
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
|
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
|
||||||
|
|
||||||
val e_a_unit : full_environment -> expression
|
val e_a_unit : full_environment -> expression
|
||||||
@ -146,8 +145,6 @@ val e_a_record : expression label_map -> full_environment -> expression
|
|||||||
val e_a_application : expression -> expression -> full_environment -> expression
|
val e_a_application : expression -> expression -> full_environment -> expression
|
||||||
val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
|
val e_a_variable : expression_variable -> type_expression -> full_environment -> expression
|
||||||
val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
|
val ez_e_a_record : ( label * expression ) list -> full_environment -> expression
|
||||||
val e_a_map : ( expression * expression ) list -> type_expression -> type_expression -> full_environment -> expression
|
|
||||||
val e_a_list : expression list -> type_expression -> full_environment -> expression
|
|
||||||
val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
|
val e_a_let_in : expression_variable -> bool -> expression -> expression -> full_environment -> expression
|
||||||
|
|
||||||
val get_a_int : expression -> int result
|
val get_a_int : expression -> int result
|
||||||
|
@ -14,8 +14,6 @@ let e_a_empty_pair a b = e_a_pair a b Environment.full_empty
|
|||||||
let e_a_empty_some s = e_a_some s Environment.full_empty
|
let e_a_empty_some s = e_a_some s Environment.full_empty
|
||||||
let e_a_empty_none t = e_a_none t Environment.full_empty
|
let e_a_empty_none t = e_a_none t Environment.full_empty
|
||||||
let e_a_empty_record r = e_a_record r Environment.full_empty
|
let e_a_empty_record r = e_a_record r Environment.full_empty
|
||||||
let e_a_empty_map lst k v = e_a_map lst k v Environment.full_empty
|
|
||||||
let e_a_empty_list lst t = e_a_list lst t Environment.full_empty
|
|
||||||
let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty
|
let ez_e_a_empty_record r = ez_e_a_record r Environment.full_empty
|
||||||
let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty
|
let e_a_empty_lambda l i o = e_a_lambda l i o Environment.full_empty
|
||||||
|
|
||||||
|
@ -13,8 +13,6 @@ val e_a_empty_pair : expression -> expression -> expression
|
|||||||
val e_a_empty_some : expression -> expression
|
val e_a_empty_some : expression -> expression
|
||||||
val e_a_empty_none : type_expression -> expression
|
val e_a_empty_none : type_expression -> expression
|
||||||
val e_a_empty_record : expression label_map -> expression
|
val e_a_empty_record : expression label_map -> expression
|
||||||
val e_a_empty_map : (expression * expression ) list -> type_expression -> type_expression -> expression
|
|
||||||
val e_a_empty_list : expression list -> type_expression -> expression
|
|
||||||
val ez_e_a_empty_record : ( label * expression ) list -> expression
|
val ez_e_a_empty_record : ( label * expression ) list -> expression
|
||||||
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
|
val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression
|
||||||
|
|
||||||
|
@ -211,10 +211,6 @@ module Free_variables = struct
|
|||||||
| E_record m -> unions @@ List.map self @@ LMap.to_list m
|
| E_record m -> unions @@ List.map self @@ LMap.to_list m
|
||||||
| E_record_accessor {record;_} -> self record
|
| E_record_accessor {record;_} -> self record
|
||||||
| E_record_update {record; update;_} -> union (self record) @@ self update
|
| E_record_update {record; update;_} -> union (self record) @@ self update
|
||||||
| E_list lst -> unions @@ List.map self lst
|
|
||||||
| E_set lst -> unions @@ List.map self lst
|
|
||||||
| (E_map m | E_big_map m) -> unions @@ List.map self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m
|
|
||||||
| E_look_up (a , b) -> unions @@ List.map self [ a ; b ]
|
|
||||||
| E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
|
| E_matching {matchee; cases;_} -> union (self matchee) (matching_expression b cases)
|
||||||
| E_let_in { let_binder; rhs; let_result; _} ->
|
| E_let_in { let_binder; rhs; let_result; _} ->
|
||||||
let b' = union (singleton let_binder) b in
|
let b' = union (singleton let_binder) b in
|
||||||
@ -342,10 +338,11 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
|
|||||||
| TC_list la, TC_list lb
|
| TC_list la, TC_list lb
|
||||||
| TC_contract la, TC_contract lb
|
| TC_contract la, TC_contract lb
|
||||||
| TC_set la, TC_set lb -> ok @@ ([la], [lb])
|
| TC_set la, TC_set lb -> ok @@ ([la], [lb])
|
||||||
| TC_map (ka,va), TC_map (kb,vb)
|
| (TC_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_map (kb,vb) | TC_map_or_big_map (kb,vb))
|
||||||
| TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb])
|
| (TC_big_map (ka,va) | TC_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb))
|
||||||
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _),
|
-> ok @@ ([ka;va] ,[kb;vb])
|
||||||
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
|
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _),
|
||||||
|
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ ) -> fail @@ different_operators opa opb
|
||||||
in
|
in
|
||||||
if List.length lsta <> List.length lstb then
|
if List.length lsta <> List.length lstb then
|
||||||
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
|
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
|
||||||
@ -497,44 +494,10 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
|
|||||||
| E_record _, _ ->
|
| E_record _, _ ->
|
||||||
fail @@ (different_values_because_different_types "record vs. non-record" a b)
|
fail @@ (different_values_because_different_types "record vs. non-record" a b)
|
||||||
|
|
||||||
| (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> (
|
|
||||||
let%bind lst = generic_try (different_size_values "maps of different lengths" a b)
|
|
||||||
(fun () ->
|
|
||||||
let lsta' = List.sort compare lsta in
|
|
||||||
let lstb' = List.sort compare lstb in
|
|
||||||
List.combine lsta' lstb') in
|
|
||||||
let aux = fun ((ka, va), (kb, vb)) ->
|
|
||||||
let%bind _ = assert_value_eq (ka, kb) in
|
|
||||||
let%bind _ = assert_value_eq (va, vb) in
|
|
||||||
ok () in
|
|
||||||
let%bind _all = bind_map_list aux lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| (E_map _ | E_big_map _), _ ->
|
|
||||||
fail @@ different_values_because_different_types "map vs. non-map" a b
|
|
||||||
|
|
||||||
| E_list lsta, E_list lstb -> (
|
|
||||||
let%bind lst =
|
|
||||||
generic_try (different_size_values "lists of different lengths" a b)
|
|
||||||
(fun () -> List.combine lsta lstb) in
|
|
||||||
let%bind _all = bind_map_list assert_value_eq lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| E_list _, _ ->
|
|
||||||
fail @@ different_values_because_different_types "list vs. non-list" a b
|
|
||||||
| E_set lsta, E_set lstb -> (
|
|
||||||
let%bind lst =
|
|
||||||
generic_try (different_size_values "sets of different lengths" a b)
|
|
||||||
(fun () -> List.combine lsta lstb) in
|
|
||||||
let%bind _all = bind_map_list assert_value_eq lst in
|
|
||||||
ok ()
|
|
||||||
)
|
|
||||||
| E_set _, _ ->
|
|
||||||
fail @@ different_values_because_different_types "set vs. non-set" a b
|
|
||||||
| (E_literal _, _) | (E_variable _, _) | (E_application _, _)
|
| (E_literal _, _) | (E_variable _, _) | (E_application _, _)
|
||||||
| (E_lambda _, _) | (E_let_in _, _) | (E_recursive _, _)
|
| (E_lambda _, _) | (E_let_in _, _) | (E_recursive _, _)
|
||||||
| (E_record_accessor _, _) | (E_record_update _,_)
|
| (E_record_accessor _, _) | (E_record_update _,_)
|
||||||
| (E_look_up _, _) | (E_matching _, _)
|
| (E_matching _, _)
|
||||||
-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
|
-> fail @@ error_uncomparable_values "can't compare sequences nor loops" a b
|
||||||
|
|
||||||
let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
|
let merge_annotation (a:type_expression option) (b:type_expression option) err : type_expression result =
|
||||||
|
@ -75,18 +75,6 @@ module Captured_variables = struct
|
|||||||
let%bind r = self record in
|
let%bind r = self record in
|
||||||
let%bind e = self update in
|
let%bind e = self update in
|
||||||
ok @@ union r e
|
ok @@ union r e
|
||||||
| E_list lst ->
|
|
||||||
let%bind lst' = bind_map_list self lst in
|
|
||||||
ok @@ unions lst'
|
|
||||||
| E_set lst ->
|
|
||||||
let%bind lst' = bind_map_list self lst in
|
|
||||||
ok @@ unions lst'
|
|
||||||
| (E_map m | E_big_map m) ->
|
|
||||||
let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in
|
|
||||||
ok @@ unions lst'
|
|
||||||
| E_look_up (a , b) ->
|
|
||||||
let%bind lst' = bind_map_list self [ a ; b ] in
|
|
||||||
ok @@ unions lst'
|
|
||||||
| E_matching {matchee;cases;_} ->
|
| E_matching {matchee;cases;_} ->
|
||||||
let%bind a' = self matchee in
|
let%bind a' = self matchee in
|
||||||
let%bind cs' = matching_expression b cases in
|
let%bind cs' = matching_expression b cases in
|
||||||
|
@ -49,13 +49,6 @@ and expression_content =
|
|||||||
| E_record of expression label_map
|
| E_record of expression label_map
|
||||||
| E_record_accessor of accessor
|
| E_record_accessor of accessor
|
||||||
| E_record_update of update
|
| E_record_update of update
|
||||||
(* Data Structures *)
|
|
||||||
(* TODO : move to constant*)
|
|
||||||
| E_map of (expression * expression) list (*move to operator *)
|
|
||||||
| E_big_map of (expression * expression) list (*move to operator *)
|
|
||||||
| E_list of expression list
|
|
||||||
| E_set of expression list
|
|
||||||
| E_look_up of (expression * expression)
|
|
||||||
|
|
||||||
and constant =
|
and constant =
|
||||||
{ cons_name: constant'
|
{ cons_name: constant'
|
||||||
|
@ -86,10 +86,6 @@ and expression' ppf (e:expression') = match e with
|
|||||||
|
|
||||||
| 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 %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments
|
||||||
| E_literal v -> fprintf ppf "L(%a)" value v
|
| E_literal v -> fprintf ppf "L(%a)" value v
|
||||||
| E_make_empty_map _ -> fprintf ppf "map[]"
|
|
||||||
| E_make_empty_big_map _ -> fprintf ppf "big_map[]"
|
|
||||||
| E_make_empty_list _ -> fprintf ppf "list[]"
|
|
||||||
| E_make_empty_set _ -> fprintf ppf "set[]"
|
|
||||||
| 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) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b
|
||||||
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s
|
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s
|
||||||
@ -199,6 +195,8 @@ and constant ppf : constant' -> unit = function
|
|||||||
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
|
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
|
||||||
| C_SET_MEM -> fprintf ppf "SET_MEM"
|
| C_SET_MEM -> fprintf ppf "SET_MEM"
|
||||||
(* List *)
|
(* List *)
|
||||||
|
| C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY"
|
||||||
|
| C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL"
|
||||||
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
|
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
|
||||||
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
|
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
|
||||||
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
|
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
|
||||||
|
@ -44,10 +44,6 @@ module Free_variables = struct
|
|||||||
| E_constant (c) -> unions @@ List.map self c.arguments
|
| E_constant (c) -> unions @@ List.map self c.arguments
|
||||||
| E_application (f, x) -> unions @@ [ self f ; self x ]
|
| E_application (f, x) -> unions @@ [ self f ; self x ]
|
||||||
| E_variable n -> var_name b n
|
| E_variable n -> var_name b n
|
||||||
| E_make_empty_map _ -> empty
|
|
||||||
| E_make_empty_big_map _ -> empty
|
|
||||||
| E_make_empty_list _ -> empty
|
|
||||||
| E_make_empty_set _ -> empty
|
|
||||||
| E_make_none _ -> empty
|
| E_make_none _ -> empty
|
||||||
| E_iterator (_, ((v, _), body), expr) ->
|
| E_iterator (_, ((v, _), body), expr) ->
|
||||||
unions [ expression (union (singleton v) b) body ;
|
unions [ expression (union (singleton v) b) body ;
|
||||||
|
@ -59,10 +59,6 @@ and expression' =
|
|||||||
| E_constant of constant
|
| E_constant of constant
|
||||||
| E_application of (expression * expression)
|
| E_application of (expression * expression)
|
||||||
| E_variable of var_name
|
| E_variable of var_name
|
||||||
| E_make_empty_map of (type_value * type_value)
|
|
||||||
| E_make_empty_big_map of (type_value * type_value)
|
|
||||||
| E_make_empty_list of type_value
|
|
||||||
| E_make_empty_set of type_value
|
|
||||||
| E_make_none of type_value
|
| E_make_none of type_value
|
||||||
| E_iterator of constant' * ((var_name * type_value) * expression) * expression
|
| E_iterator of constant' * ((var_name * type_value) * expression) * expression
|
||||||
| E_fold of (((var_name * type_value) * expression) * expression * expression)
|
| E_fold of (((var_name * type_value) * expression) * expression * expression)
|
||||||
|
@ -105,6 +105,8 @@ let constant ppf : constant' -> unit = function
|
|||||||
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
|
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
|
||||||
| C_SET_MEM -> fprintf ppf "SET_MEM"
|
| C_SET_MEM -> fprintf ppf "SET_MEM"
|
||||||
(* List *)
|
(* List *)
|
||||||
|
| C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY"
|
||||||
|
| C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL"
|
||||||
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
|
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
|
||||||
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
|
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
|
||||||
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
|
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
|
||||||
@ -263,6 +265,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set te -> Format.asprintf "set(%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_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_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v
|
||||||
|
| TC_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v
|
||||||
| TC_arrow (k, v) -> Format.asprintf "arrow (%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
|
| TC_contract te -> Format.asprintf "Contract (%a)" f te
|
||||||
in
|
in
|
||||||
|
@ -53,6 +53,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set of type_expression
|
| TC_set of type_expression
|
||||||
| TC_map of type_expression * type_expression
|
| TC_map of type_expression * type_expression
|
||||||
| TC_big_map of type_expression * type_expression
|
| TC_big_map of type_expression * type_expression
|
||||||
|
| TC_map_or_big_map of type_expression * type_expression
|
||||||
| TC_arrow of type_expression * type_expression
|
| TC_arrow of type_expression * type_expression
|
||||||
|
|
||||||
|
|
||||||
@ -66,6 +67,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set x -> TC_set (f x)
|
| TC_set x -> TC_set (f x)
|
||||||
| TC_map (x , y) -> TC_map (f x , f y)
|
| TC_map (x , y) -> TC_map (f x , f y)
|
||||||
| TC_big_map (x , y)-> TC_big_map (f x , f y)
|
| TC_big_map (x , y)-> TC_big_map (f x , f y)
|
||||||
|
| TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y)
|
||||||
| TC_arrow (x, y) -> TC_arrow (f x, f y)
|
| TC_arrow (x, y) -> TC_arrow (f x, f y)
|
||||||
|
|
||||||
let bind_map_type_operator f = function
|
let bind_map_type_operator f = function
|
||||||
@ -75,6 +77,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set x -> let%bind x = f x in ok @@ TC_set x
|
| TC_set x -> let%bind x = f x in ok @@ TC_set x
|
||||||
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
|
| TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y)
|
||||||
| TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
|
| TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y)
|
||||||
|
| TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y)
|
||||||
| TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
|
| TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y)
|
||||||
|
|
||||||
let type_operator_name = function
|
let type_operator_name = function
|
||||||
@ -84,6 +87,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set _ -> "TC_set"
|
| TC_set _ -> "TC_set"
|
||||||
| TC_map _ -> "TC_map"
|
| TC_map _ -> "TC_map"
|
||||||
| TC_big_map _ -> "TC_big_map"
|
| TC_big_map _ -> "TC_big_map"
|
||||||
|
| TC_map_or_big_map _ -> "TC_map_or_big_map"
|
||||||
| TC_arrow _ -> "TC_arrow"
|
| TC_arrow _ -> "TC_arrow"
|
||||||
|
|
||||||
let type_expression'_of_string = function
|
let type_expression'_of_string = function
|
||||||
@ -122,6 +126,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct
|
|||||||
| TC_set x -> "TC_set" , [x]
|
| TC_set x -> "TC_set" , [x]
|
||||||
| TC_map (x , y) -> "TC_map" , [x ; y]
|
| TC_map (x , y) -> "TC_map" , [x ; y]
|
||||||
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
|
| TC_big_map (x , y) -> "TC_big_map" , [x ; y]
|
||||||
|
| TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y]
|
||||||
| TC_arrow (x , y) -> "TC_arrow" , [x ; y]
|
| TC_arrow (x , y) -> "TC_arrow" , [x ; y]
|
||||||
|
|
||||||
let string_of_type_constant = function
|
let string_of_type_constant = function
|
||||||
@ -247,6 +252,8 @@ and constant' =
|
|||||||
| C_SET_FOLD
|
| C_SET_FOLD
|
||||||
| C_SET_MEM
|
| C_SET_MEM
|
||||||
(* List *)
|
(* List *)
|
||||||
|
| C_LIST_EMPTY
|
||||||
|
| C_LIST_LITERAL
|
||||||
| C_LIST_ITER
|
| C_LIST_ITER
|
||||||
| C_LIST_MAP
|
| C_LIST_MAP
|
||||||
| C_LIST_FOLD
|
| C_LIST_FOLD
|
||||||
|
@ -190,30 +190,6 @@ module Substitution = struct
|
|||||||
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
|
||||||
ok @@ T.E_record_update {record;path;update}
|
ok @@ T.E_record_update {record;path;update}
|
||||||
| T.E_map val_val_list ->
|
|
||||||
let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
|
|
||||||
let%bind val1 = s_expression ~substs val1 in
|
|
||||||
let%bind val2 = s_expression ~substs val2 in
|
|
||||||
ok @@ (val1 , val2)
|
|
||||||
) val_val_list in
|
|
||||||
ok @@ T.E_map val_val_list
|
|
||||||
| T.E_big_map val_val_list ->
|
|
||||||
let%bind val_val_list = bind_map_list (fun (val1 , val2) ->
|
|
||||||
let%bind val1 = s_expression ~substs val1 in
|
|
||||||
let%bind val2 = s_expression ~substs val2 in
|
|
||||||
ok @@ (val1 , val2)
|
|
||||||
) val_val_list in
|
|
||||||
ok @@ T.E_big_map val_val_list
|
|
||||||
| T.E_list vals ->
|
|
||||||
let%bind vals = bind_map_list (s_expression ~substs) vals in
|
|
||||||
ok @@ T.E_list vals
|
|
||||||
| T.E_set vals ->
|
|
||||||
let%bind vals = bind_map_list (s_expression ~substs) vals in
|
|
||||||
ok @@ T.E_set vals
|
|
||||||
| T.E_look_up (val1, val2) ->
|
|
||||||
let%bind val1 = s_expression ~substs val1 in
|
|
||||||
let%bind val2 = s_expression ~substs val2 in
|
|
||||||
ok @@ T.E_look_up (val1 , val2)
|
|
||||||
| T.E_matching {matchee;cases} ->
|
| T.E_matching {matchee;cases} ->
|
||||||
let%bind matchee = s_expression ~substs matchee in
|
let%bind matchee = s_expression ~substs matchee in
|
||||||
let%bind cases = s_matching_expr ~substs cases in
|
let%bind cases = s_matching_expr ~substs cases in
|
||||||
|
Loading…
Reference in New Issue
Block a user