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

Merge branch 'feature/adt-generator-8-run-dev' into 'dev'

Browse Source 
Started using the ADT generator, and small improvements to it

See merge request ligolang/ligo!559
This commit is contained in:
Suzanne Dupéron 2020-04-13 20:54:19 +00:00
commit 0e699702ad
44 changed files with 2175 additions and 992 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/passes/10-interpreter/interpreter.ml
View File

@ -1,7 +1,7 @@
open Trace
open Ligo_interpreter.Types
open Ligo_interpreter.Combinators
include Stage_common.Types
include Ast_typed.Types
module Env = Ligo_interpreter.Environment
@ -210,7 +210,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| ( C_SET_MEM , [ v ; V_Set (elts) ] ) -> ok @@ v_bool (List.mem v elts)
| ( C_SET_REMOVE , [ v ; V_Set (elts) ] ) -> ok @@ V_Set (List.filter (fun el -> not (el = v)) elts)
| _ ->
let () = Format.printf "%a\n" Stage_common.PP.constant c in
let () = Format.printf "%a\n" Ast_typed.PP.constant c in
let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
simple_fail "Unsupported constant op"
)
@ -338,25 +338,24 @@ and eval : Ast_typed.expression -> env -> value result
| Match_list cases , V_List [] ->
eval cases.match_nil env
| Match_list cases , V_List (head::tail) ->
let (head_var,tail_var,body,_) = cases.match_cons in
let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in
let {hd;tl;body;tv=_} = cases.match_cons in
let env' = Env.extend (Env.extend env (hd,head)) (tl, V_List tail) in
eval body env'
| Match_variant (case_list , _) , V_Construct (matched_c , proj) ->
let ((_, var) , body) =
| Match_variant {cases ; tv=_} , V_Construct (matched_c , proj) ->
let {constructor=_ ; pattern ; body} =
List.find
(fun case ->
let (Constructor c , _) = fst case in
(fun {constructor = (Constructor c) ; pattern=_ ; body=_} ->
String.equal matched_c c)
case_list in
let env' = Env.extend env (var, proj) in
cases in
let env' = Env.extend env (pattern, proj) in
eval body env'
| Match_bool cases , V_Ct (C_bool true) ->
eval cases.match_true env
| Match_bool cases , V_Ct (C_bool false) ->
eval cases.match_false env
| Match_option cases, V_Construct ("Some" , proj) ->
let (var,body,_) = cases.match_some in
let env' = Env.extend env (var,proj) in
let {opt;body;tv=_} = cases.match_some in
let env' = Env.extend env (opt,proj) in
eval body env'
| Match_option cases, V_Construct ("None" , V_Ct C_unit) ->
eval cases.match_none env
@ -370,16 +369,16 @@ let dummy : Ast_typed.program -> string result =
fun prg ->
let%bind (res,_) = bind_fold_list
(fun (pp,top_env) el ->
let (Ast_typed.Declaration_constant (exp_name, exp , _ , _)) = Location.unwrap el in
let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
eval exp top_env
eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s
(*TODO This TRY-CATCH is here until we properly implement effects*)
in
let pp' = pp^"\n val "^(Var.to_name exp_name)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (exp_name, v) in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env')
)
("",Env.empty_env) prg in

6
src/passes/10-transpiler/helpers.ml
View File

@ -3,7 +3,9 @@ module Append_tree = Tree.Append
open Trace
open Mini_c
open Stage_common.Types (*Todo : to remove *)
(* open Stage_common.Types (\*Todo : to remove *\) *)
module LMap = AST.Types.LMap
module CMap = AST.Types.CMap
let list_of_lmap m = List.rev @@ LMap.fold (fun _ v prev -> v :: prev) m []
let kv_list_of_lmap m = List.rev @@ LMap.fold (fun k v prev -> (k, v) :: prev) m []
@ -25,7 +27,7 @@ let extract_constructor (v : value) (tree : _ Append_tree.t') : (string * value
let open Append_tree in
let rec aux tv : (string * value * AST.type_expression) result=
match tv with
| Leaf (Constructor k, t), v -> ok (k, v, t)
| Leaf (Ast_typed.Constructor k, t), v -> ok (k, v, t)
| Node {a}, D_left v -> aux (a, v)
| Node {b}, D_right v -> aux (b, v)
| _ -> fail @@ internal_assertion_failure "bad constructor path"

210
src/passes/10-transpiler/transpiler.ml
View File

@ -114,6 +114,121 @@ them. please report this to the developers." in
end
open Errors
let transpile_constant' : AST.constant' -> constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let rec transpile_type (t:AST.type_expression) : type_value result =
match t.type_content with
| T_variable (name) -> fail @@ no_type_variable @@ name
@ -135,15 +250,15 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
| T_operator (TC_contract x) ->
let%bind x' = transpile_type x in
ok (T_contract x')
| T_operator (TC_map (key,value)) ->
let%bind kv' = bind_map_pair transpile_type (key, value) in
| T_operator (TC_map {k;v}) ->
let%bind kv' = bind_map_pair transpile_type (k, v) in
ok (T_map kv')
| T_operator (TC_big_map (key,value)) ->
let%bind kv' = bind_map_pair transpile_type (key, value) in
| T_operator (TC_big_map {k;v}) ->
let%bind kv' = bind_map_pair transpile_type (k, v) in
ok (T_big_map kv')
| T_operator (TC_map_or_big_map (_,_)) ->
| 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_michelson_or (l,r)) ->
| T_operator (TC_michelson_or {l;r}) ->
let%bind l' = transpile_type l in
let%bind r' = transpile_type r in
ok (T_or ((None,l'),(None,r')))
@ -156,7 +271,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
| T_operator (TC_option o) ->
let%bind o' = transpile_type o in
ok (T_option o')
| T_operator (TC_arrow (param , result)) -> (
| T_operator (TC_arrow {type1=param ; type2=result}) -> (
let%bind param' = transpile_type param in
let%bind result' = transpile_type result in
ok (T_function (param', result'))
@ -170,20 +285,20 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
ok (None, T_or (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Stage_common.Types.Constructor ann, a) ->
(fun (Ast_typed.Types.Constructor ann, a) ->
let%bind a = transpile_type a in
ok (Some (String.uncapitalize_ascii ann), a))
aux node in
ok @@ snd m'
| T_record m ->
let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in
let node = Append_tree.of_list @@ Ast_typed.Helpers.kv_list_of_record_or_tuple m in
let aux a b : type_value annotated result =
let%bind a = a in
let%bind b = b in
ok (None, T_pair (a, b))
in
let%bind m' = Append_tree.fold_ne
(fun (Stage_common.Types.Label ann, a) ->
(fun (Ast_typed.Types.Label ann, a) ->
let%bind a = transpile_type a in
ok (Some ann, a))
aux node in
@ -195,7 +310,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result =
)
let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind ->
let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in
let tys = Ast_typed.Helpers.kv_list_of_record_or_tuple tym in
let node_tv = Append_tree.of_list tys in
let%bind path =
let aux (i , _) = i = ind in
@ -295,7 +410,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
)
| E_record m -> (
(*list_of_lmap to record_to_list*)
let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in
let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in
let aux a b : expression result =
let%bind a = a in
let%bind b = b in
@ -312,7 +427,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_expression record) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap path in
@ -329,7 +444,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let%bind ty_lmap =
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
get_t_record (get_type_expression record) in
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap transpile_type ty_lmap in
let%bind path =
trace_strong (corner_case ~loc:__LOC__ "record access") @@
record_access_to_lr ty' ty'_lmap path in
@ -388,7 +503,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| (C_MAP_FOLD , lst) -> fold lst
| _ -> (
let%bind lst' = bind_map_list (transpile_annotated_expression) lst in
return @@ E_constant {cons_name=name;arguments=lst'}
return @@ E_constant {cons_name=transpile_constant' name;arguments=lst'}
)
)
| E_lambda l ->
@ -402,30 +517,30 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
| Match_bool {match_true ; match_false} ->
let%bind (t , f) = bind_map_pair (transpile_annotated_expression) (match_true, match_false) in
return @@ E_if_bool (expr', t, f)
| Match_option { match_none; match_some = (name, s, tv) } ->
| Match_option { match_none; match_some = {opt; body; tv} } ->
let%bind n = transpile_annotated_expression match_none in
let%bind (tv' , s') =
let%bind tv' = transpile_type tv in
let%bind s' = transpile_annotated_expression s in
let%bind s' = transpile_annotated_expression body in
ok (tv' , s')
in
return @@ E_if_none (expr' , n , ((name , tv') , s'))
return @@ E_if_none (expr' , n , ((opt , tv') , s'))
| Match_list {
match_nil ;
match_cons = ((hd_name) , (tl_name), match_cons, ty) ;
match_cons = {hd; tl; body; tv} ;
} -> (
let%bind nil = transpile_annotated_expression match_nil in
let%bind cons =
let%bind ty' = transpile_type ty in
let%bind match_cons' = transpile_annotated_expression match_cons in
ok (((hd_name , ty') , (tl_name , ty')) , match_cons')
let%bind ty' = transpile_type tv in
let%bind match_cons' = transpile_annotated_expression body in
ok (((hd , ty') , (tl , ty')) , match_cons')
in
return @@ E_if_cons (expr' , nil , cons)
)
| Match_variant (lst , variant) -> (
| Match_variant {cases ; tv} -> (
let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
tree_of_sum tv in
let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in
@ -445,12 +560,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let rec aux top t =
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
| ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let aux ({constructor = Constructor c ; pattern=_ ; body=_} : AST.matching_content_case) =
(c = constructor_name) in
List.find_opt aux cases in
let%bind body' = transpile_annotated_expression body in
return @@ E_let_in ((name , tv) , false , top , body')
return @@ E_let_in ((pattern , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
@ -523,30 +640,30 @@ and transpile_recursive {fun_name; fun_type; lambda} =
Match_bool {match_true; match_false} ->
let%bind (t , f) = bind_map_pair (replace_callback fun_name loop_type shadowed) (match_true, match_false) in
return @@ E_if_bool (expr, t, f)
| Match_option { match_none; match_some = (name, s, tv) } ->
| Match_option { match_none; match_some = {opt; body; tv} } ->
let%bind n = replace_callback fun_name loop_type shadowed match_none in
let%bind (tv' , s') =
let%bind tv' = transpile_type tv in
let%bind s' = replace_callback fun_name loop_type shadowed s in
let%bind s' = replace_callback fun_name loop_type shadowed body in
ok (tv' , s')
in
return @@ E_if_none (expr , n , ((name , tv') , s'))
return @@ E_if_none (expr , n , ((opt , tv') , s'))
| Match_list {
match_nil ;
match_cons = ((hd_name) , (tl_name), match_cons, ty) ;
match_cons = { hd ; tl ; body ; tv } ;
} -> (
let%bind nil = replace_callback fun_name loop_type shadowed match_nil in
let%bind cons =
let%bind ty' = transpile_type ty in
let%bind match_cons' = replace_callback fun_name loop_type shadowed match_cons in
ok (((hd_name , ty') , (tl_name , ty')) , match_cons')
let%bind ty' = transpile_type tv in
let%bind match_cons' = replace_callback fun_name loop_type shadowed body in
ok (((hd , ty') , (tl , ty')) , match_cons')
in
return @@ E_if_cons (expr , nil , cons)
)
| Match_variant (lst , variant) -> (
| Match_variant {cases;tv} -> (
let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
tree_of_sum tv in
let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in
@ -565,12 +682,14 @@ and transpile_recursive {fun_name; fun_type; lambda} =
in
let rec aux top t =
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
| ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let aux ({constructor = Constructor c ; pattern=_ ; body=_} : AST.matching_content_case) =
(c = constructor_name) in
List.find_opt aux cases in
let%bind body' = replace_callback fun_name loop_type shadowed body in
return @@ E_let_in ((name , tv) , false , top , body')
return @@ E_let_in ((pattern , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
@ -604,12 +723,11 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant (name,expression, inline, _) ->
let name = name in
let%bind expression = transpile_annotated_expression expression in
| Declaration_constant { binder ; expr ; inline ; post_env=_ } ->
let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in
ok @@ ((name, inline, expression), environment_wrap env env')
let env' = Environment.add (binder, tv) env in
ok @@ ((binder, inline, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =

29
src/passes/10-transpiler/untranspiler.ml
View File

@ -150,43 +150,42 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind s' = untranspile s o in
ok (e_a_empty_some s')
)
| TC_map (k_ty,v_ty)-> (
| TC_map {k=k_ty;v=v_ty}-> (
let%bind map =
trace_strong (wrong_mini_c_value "map" v) @@
get_map v in
let%bind map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
let%bind k = untranspile k k_ty in
let%bind v = untranspile v v_ty in
ok ({k; v} : AST.map_kv) in
bind_map_list aux map in
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]}
let aux = fun prev ({ k ; v } : AST.map_kv) ->
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=k_ty; v=v_ty} -> (
let%bind big_map =
trace_strong (wrong_mini_c_value "big_map" v) @@
get_big_map v in
let%bind big_map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
let%bind k = untranspile k k_ty in
let%bind v = untranspile v v_ty in
ok ({k; v} : AST.map_kv) in
bind_map_list aux big_map in
let big_map' = List.sort_uniq compare big_map' in
let aux = fun prev (k, v) ->
let aux = fun prev ({ k ; v } : AST.map_kv) ->
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_michelson_or (l_ty, r_ty) -> (
| TC_map_or_big_map _ -> fail @@ corner_case ~loc:"untranspiler" "TC_map_or_big_map t should not be present in mini-c"
| TC_michelson_or {l=l_ty; r=r_ty} -> (
let%bind v' = bind_map_or (get_left , get_right) v in
( match v' with
| D_left l ->
@ -244,7 +243,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
let%bind sub = untranspile v tv in
return (E_constructor {constructor=Constructor name;element=sub})
| T_record m ->
let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in
let lst = Ast_typed.Helpers.kv_list_of_record_or_tuple m in
let%bind node = match Append_tree.of_list lst with
| Empty -> fail @@ corner_case ~loc:__LOC__ "empty record"
| Full t -> ok t in

18
src/passes/8-typer-new/solver.ml
View File

@ -66,15 +66,15 @@ module Wrap = struct
P_constant (csttag, [])
| T_operator (type_operator) ->
let (csttag, args) = Core.(match type_operator with
| TC_option o -> (C_option, [o])
| TC_set s -> (C_set, [s])
| TC_map ( k , v ) -> (C_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_michelson_or ( k , v) -> (C_michelson_or, [k;v])
| TC_arrow ( arg , ret ) -> (C_arrow, [ arg ; ret ])
| TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
| TC_option o -> (C_option, [o])
| TC_set s -> (C_set, [s])
| TC_map { k ; v } -> (C_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_michelson_or { l; r } -> (C_michelson_or, [l;r])
| TC_arrow { type1 ; type2 } -> (C_arrow, [ type1 ; type2 ])
| TC_list l -> (C_list, [l])
| TC_contract c -> (C_contract, [c])
)
in
P_constant (csttag, List.map type_expression_to_type_value args)

429
src/passes/8-typer-new/typer.ml
View File

@ -163,6 +163,274 @@ end
open Errors
let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.Constructor c
let convert_label (I.Label c) = O.Label c
let unconvert_label (O.Label c) = I.Label c
let convert_type_constant : I.type_constant -> O.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let unconvert_type_constant : O.type_constant -> I.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let convert_constant' : I.constant' -> O.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let unconvert_constant' : O.constant' -> I.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
(*
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) =
@ -187,16 +455,16 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', state , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , inline, expression) -> (
(*
Determine the type of the expression and add it to the environment
*)
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind (ae' , state') =
trace (constant_declaration_error name expression tv'_opt) @@
let%bind (expr , state') =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', state' , Some (O.Declaration_constant (name, ae', inline, env') ))
let post_env = Environment.add_ez_ae binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline ; post_env} ))
)
and type_match : environment -> Solver.state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * Solver.state) result =
@ -209,14 +477,14 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
let%bind (match_false , state'') = type_expression e state' match_false in
ok (O.Match_bool {match_true ; match_false} , state'')
| Match_option {match_none ; match_some} ->
let%bind t_opt =
let%bind tv =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind (match_none , state') = type_expression e state match_none in
let (n, b, _) = match_some in
let e' = Environment.add_ez_binder n t_opt e in
let%bind (b' , state'') = type_expression e' state' b in
ok (O.Match_option {match_none ; match_some = (n, b', t_opt)} , state'')
let (opt, b, _) = match_some in
let e' = Environment.add_ez_binder opt tv e in
let%bind (body , state'') = type_expression e' state' b in
ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'')
| Match_list {match_nil ; match_cons} ->
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
@ -225,19 +493,19 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
let (hd, tl, b, _) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind (b' , state'') = type_expression e' state' b in
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b',t)} , state'')
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
let%bind (body , state'') = type_expression e' state' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst loc)
@@ (fun () -> List.combine lst t_tuple) in
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind (b' , state') = type_expression e' state b in
ok (O.Match_tuple ((lst, b'), t_tuple) , state')
let%bind (body , state') = type_expression e' state b in
ok (O.Match_tuple {vars ; body ; tvs} , state')
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
@ -267,8 +535,8 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ I.CMap.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
in
@ -280,17 +548,18 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in
let%bind (state'' , lst') =
let aux state ((constructor_name , name) , b) =
let%bind (state'' , cases) =
let aux state ((constructor_name , pattern) , b) =
let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in
let%bind (b' , state') = type_expression e' state b in
ok (state' , ((constructor_name , name) , b'))
let e' = Environment.add_ez_binder pattern constructor e in
let%bind (body , state') = type_expression e' state b in
let constructor = convert_constructor' constructor_name in
ok (state' , ({constructor ; pattern ; body = body} : O.matching_content_case))
in
bind_fold_map_list aux state lst in
ok (O.Match_variant (lst' , variant) , state'')
ok (O.Match_variant {cases ; tv=variant } , state'')
(*
Recursively search the type_expression and return a result containing the
@ -307,17 +576,17 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ I.CMap.add k v' prev'
ok @@ O.CMap.add (convert_constructor' k) v' prev'
in
let%bind m = I.CMap.fold aux m (ok I.CMap.empty) in
let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
return (T_sum m)
| T_record m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ I.LMap.add k v' prev'
ok @@ O.LMap.add (convert_label k) v' prev'
in
let%bind m = I.LMap.fold aux m (ok I.LMap.empty) in
let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in
return (T_record m)
| T_variable name ->
let%bind tv =
@ -325,7 +594,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
@@ Environment.get_type_opt (name) e in
ok tv
| T_constant cst ->
return (T_constant cst)
return (T_constant (convert_type_constant cst))
| T_operator opt ->
let%bind opt = match opt with
| TC_set s ->
@ -340,26 +609,26 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| TC_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map (k,v)
ok @@ O.TC_map {k;v}
| TC_big_map (k,v) ->
let%bind k = evaluate_type e k 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)
ok @@ O.TC_map_or_big_map {k;v}
| TC_michelson_or (l,r) ->
let%bind l = evaluate_type e l in
let%bind r = evaluate_type e r in
ok @@ O.TC_michelson_or (l,r)
ok @@ O.TC_michelson_or {l;r}
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
| TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in
ok @@ O.TC_arrow ( arg' , ret' )
ok @@ O.TC_arrow { type1=arg' ; type2=ret' }
in
return (T_operator (opt))
@ -461,6 +730,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
* ) *)
| E_record_accessor {record;path} -> (
let%bind (base' , state') = type_expression e state record in
let path = convert_label path in
let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in
return_wrapped (E_record_accessor {record=base';path}) state' wrapped
)
@ -481,28 +751,30 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let%bind (expr' , state') = type_expression e state element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
let wrapped = Wrap.constructor expr'.type_expression c_tv sum_tv in
let constructor = convert_constructor' constructor in
return_wrapped (E_constructor {constructor; element=expr'}) state' wrapped
(* Record *)
| E_record m ->
let aux (acc, state) k expr =
let%bind (expr' , state') = type_expression e state expr in
ok (I.LMap.add k expr' acc , state')
ok (O.LMap.add (convert_label k) expr' acc , state')
in
let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (I.LMap.empty , state)) m in
let wrapped = Wrap.record (I.LMap.map get_type_expression m') in
let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (O.LMap.empty , state)) m in
let wrapped = Wrap.record (O.LMap.map get_type_expression m') in
return_wrapped (E_record m') state' wrapped
| E_record_update {record; path; update} ->
let%bind (record, state) = type_expression e state record in
let%bind (update,state) = type_expression e state update in
let wrapped = get_type_expression record in
let path = convert_label path in
let%bind (wrapped,tv) =
match wrapped.type_content with
| T_record record -> (
let field_op = I.LMap.find_opt path record in
let field_op = O.LMap.find_opt path record in
match field_op with
| Some tv -> ok (record,tv)
| None -> failwith @@ Format.asprintf "field %a is not part of record" Stage_common.PP.label path
| None -> failwith @@ Format.asprintf "field %a is not part of record" O.PP.label path
)
| _ -> failwith "Update an expression which is not a record"
in
@ -510,6 +782,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *)
(* | E_lambda {
* binder ;
* input_type ;
@ -558,7 +831,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let wrapped = Wrap.application f'.type_expression args.type_expression in
return_wrapped (E_application {lamb=f';args}) state'' wrapped
(* Advanced *)
(* | E_matching (ex, m) -> (
* let%bind ex' = type_expression e ex in
@ -608,13 +880,13 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let%bind (ex' , state') = type_expression e state matchee in
let%bind (m' , state'') = type_match e state' ex'.type_expression cases ae ae.location in
let tvs =
let aux (cur:(O.expression, O.type_expression) O.matching_content) =
let aux (cur : O.matching_expr) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
| Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
| Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in
List.map get_type_expression @@ aux m' in
let%bind () = match tvs with
[] -> fail @@ match_empty_variant cases ae.location
@ -667,7 +939,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
return_wrapped (E_recursive {fun_name;fun_type;lambda}) state wrapped
| E_constant {cons_name=name; arguments=lst} ->
let () = ignore (name , lst) in
let name = convert_constant' name in
let%bind t = Operators.Typer.Operators_types.constant_type name in
let aux acc expr =
let (lst , state) = acc in
@ -705,6 +977,7 @@ and type_lambda e state {
(* Advanced *)
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
let name = convert_constant' name in
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
@ -814,13 +1087,21 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
(* TODO: or should we use t.core if present? *)
let%bind t = match t.type_content with
| O.T_sum x ->
let%bind x' = Stage_common.Helpers.bind_map_cmap untype_type_expression x in
let aux k v acc =
let%bind acc = acc in
let%bind v' = untype_type_expression v in
ok @@ I.CMap.add (unconvert_constructor' k) v' acc in
let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in
ok @@ I.T_sum x'
| O.T_record x ->
let%bind x' = Stage_common.Helpers.bind_map_lmap untype_type_expression x in
let aux k v acc =
let%bind acc = acc in
let%bind v' = untype_type_expression v in
ok @@ I.LMap.add (unconvert_label k) v' acc in
let%bind x' = O.LMap.fold aux x (ok I.LMap.empty) in
ok @@ I.T_record x'
| O.T_constant (tag) ->
ok @@ I.T_constant (tag)
ok @@ I.T_constant (unconvert_type_constant tag)
| O.T_variable (name) -> ok @@ I.T_variable (name) (* TODO: is this the right conversion? *)
| O.T_arrow {type1;type2} ->
let%bind type1 = untype_type_expression type1 in
@ -837,23 +1118,23 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul
| O.TC_set t ->
let%bind t' = untype_type_expression t in
ok @@ I.TC_set t'
| O.TC_map (k,v) ->
| O.TC_map {k;v} ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_map (k,v)
| O.TC_big_map (k,v) ->
| O.TC_big_map {k;v} ->
let%bind k = untype_type_expression k in
let%bind v = untype_type_expression v in
ok @@ I.TC_big_map (k,v)
| O.TC_map_or_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_michelson_or (l,r) ->
| O.TC_michelson_or {l;r} ->
let%bind l = untype_type_expression l in
let%bind r = untype_type_expression r in
ok @@ I.TC_michelson_or (l,r)
| O.TC_arrow ( arg , ret ) ->
| O.TC_arrow { type1=arg ; type2=ret } ->
let%bind arg' = untype_type_expression arg in
let%bind ret' = untype_type_expression ret in
ok @@ I.TC_arrow ( arg' , ret' )
@ -904,7 +1185,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
return (e_literal l)
| E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant cons_name lst')
return (e_constant (unconvert_constant' cons_name) lst')
| E_variable (n) ->
return (e_variable (n))
| E_application {lamb;args} ->
@ -920,8 +1201,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let r = LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (k,e) -> let%bind e = untype_expression e in ok (k,e)) r in
let r = O.LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (O.Label k,e) -> let%bind e = untype_expression e in ok (I.Label k,e)) r in
return (e_record @@ LMap.of_list r')
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
@ -930,7 +1211,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
| E_record_update {record; path; update} ->
let%bind r' = untype_expression record in
let%bind e = untype_expression update in
return (e_record_update r' path e)
return (e_record_update r' (unconvert_label path) e)
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in
@ -964,22 +1245,22 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some,_)} ->
| Match_tuple { vars ; body ; tvs=_ } ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f some in
let match_some = v, some, () in
let%bind some = f body in
let match_some = opt, some, () in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = (hd_name, tl_name, cons,_)} ->
| Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} ->
let%bind match_nil = f match_nil in
let%bind cons = f cons in
let match_cons = hd_name , tl_name , cons, () in
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
| Match_variant { cases ; tv=_ } ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind body = f body in
ok ((unconvert_constructor' constructor,pattern),body) in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())

405
src/passes/8-typer-old/typer.ml
View File

@ -217,6 +217,256 @@ module Errors = struct
end
open Errors
let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.Constructor c
let convert_label (I.Label c) = O.Label c
let convert_type_constant : I.type_constant -> O.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let convert_constant' : I.constant' -> O.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let unconvert_constant' : O.constant' -> I.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let rec type_program (p:I.program) : (O.program * Solver.state) result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
@ -236,13 +486,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind ae' =
trace (constant_declaration_error name expression tv'_opt) @@
let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant (name,ae', inline, env')))
let post_env = Environment.add_ez_ae binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline ; post_env}))
)
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
@ -255,14 +505,14 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
let%bind match_false = f e match_false in
ok (O.Match_bool {match_true ; match_false})
| Match_option {match_none ; match_some} ->
let%bind t_opt =
let%bind tv =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in
let%bind match_none = f e match_none in
let (n, b,_) = match_some in
let e' = Environment.add_ez_binder n t_opt e in
let%bind b' = f e' b in
ok (O.Match_option {match_none ; match_some = (n, b', t_opt)})
let (opt, b,_) = match_some in
let e' = Environment.add_ez_binder opt tv e in
let%bind body = f e' b in
ok (O.Match_option {match_none ; match_some = {opt; body; tv}})
| Match_list {match_nil ; match_cons} ->
let%bind t_elt =
trace_strong (match_error ~expected:i ~actual:t loc)
@ -271,19 +521,19 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
let (hd, tl, b,_) = match_cons in
let e' = Environment.add_ez_binder hd t_elt e in
let e' = Environment.add_ez_binder tl t e' in
let%bind b' = f e' b in
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b', t_elt)})
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
let%bind body = f e' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst loc)
@@ (fun () -> List.combine lst t_tuple) in
let%bind vars' =
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind b' = f e' b in
ok (O.Match_tuple ((lst, b'),t_tuple))
let e' = List.fold_left aux e vars' in
let%bind body = f e' b in
ok (O.Match_tuple { vars ; body ; tvs})
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
@ -306,15 +556,15 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
ok acc in
trace (simple_info "in match variant") @@
bind_fold_list aux None lst in
let%bind variant =
let%bind tv =
trace_option (match_empty_variant i loc) @@
variant_opt in
let%bind () =
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ I.CMap.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in
@@ Ast_typed.Combinators.get_t_sum tv in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
in
@ -326,17 +576,18 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in
let%bind lst' =
let aux ((constructor_name , name) , b) =
let%bind cases =
let aux ((constructor_name , pattern) , b) =
let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in
let%bind b' = f e' b in
ok ((constructor_name , name) , b')
let e' = Environment.add_ez_binder pattern constructor e in
let%bind body = f e' b in
let constructor = convert_constructor' constructor_name in
ok ({constructor ; pattern ; body} : O.matching_content_case)
in
bind_map_list aux lst in
ok (O.Match_variant (lst' , variant))
ok (O.Match_variant { cases ; tv })
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t tv' (Some t)) in
@ -355,17 +606,17 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
ok ()
else fail (redundant_constructor e k)
| None -> ok () in
ok @@ I.CMap.add k v' prev'
ok @@ O.CMap.add (convert_constructor' k) v' prev'
in
let%bind m = I.CMap.fold aux m (ok I.CMap.empty) in
let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in
return (T_sum m)
| T_record m ->
let aux k v prev =
let%bind prev' = prev in
let%bind v' = evaluate_type e v in
ok @@ I.LMap.add k v' prev'
ok @@ O.LMap.add (convert_label k) v' prev'
in
let%bind m = I.LMap.fold aux m (ok I.LMap.empty) in
let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in
return (T_record m)
| T_variable name ->
let%bind tv =
@ -373,7 +624,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
@@ Environment.get_type_opt (name) e in
ok tv
| T_constant cst ->
return (T_constant cst)
return (T_constant (convert_type_constant cst))
| T_operator opt ->
let%bind opt = match opt with
| TC_set s ->
@ -388,23 +639,23 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu
| TC_map (k,v) ->
let%bind k = evaluate_type e k in
let%bind v = evaluate_type e v in
ok @@ O.TC_map (k,v)
ok @@ O.TC_map {k;v}
| TC_big_map (k,v) ->
let%bind k = evaluate_type e k 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)
ok @@ O.TC_map_or_big_map {k;v}
| TC_michelson_or (l,r) ->
let%bind l = evaluate_type e l in
let%bind r = evaluate_type e r in
ok @@ O.TC_michelson_or (l,r)
ok @@ O.TC_michelson_or {l;r}
| TC_arrow ( arg , ret ) ->
let%bind arg' = evaluate_type e arg in
let%bind ret' = evaluate_type e ret in
ok @@ O.TC_arrow ( arg' , ret' )
ok @@ O.TC_arrow { type1=arg' ; type2=ret' }
| TC_contract c ->
let%bind c = evaluate_type e c in
ok @@ O.TC_contract c
@ -477,9 +728,9 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind r_tv = get_t_record prev.type_expression in
let%bind tv =
generic_try (bad_record_access property ae prev.type_expression ae.location)
@@ (fun () -> I.LMap.find property r_tv) in
@@ (fun () -> O.LMap.find (convert_label property) r_tv) in
let location = ae.location in
ok @@ make_e ~location (E_record_accessor {record=prev; path=property}) tv e
ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv e
in
let%bind ae =
trace (simple_info "accessing") @@ aux e' path in
@ -494,7 +745,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let%bind expr' = type_expression' e element in
( match t.type_content with
| T_sum c ->
let ct = I.CMap.find (I.Constructor s) c in
let ct = O.CMap.find (O.Constructor s) c in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, ct) in
return (E_constructor {constructor = Constructor s; element=expr'}) t
| _ -> simple_fail "ll"
@ -515,27 +766,28 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
Environment.get_constructor constructor e in
let%bind expr' = type_expression' e element in
let%bind _assert = O.assert_type_expression_eq (expr'.type_expression, c_tv) in
let constructor = convert_constructor' constructor in
return (E_constructor {constructor; element=expr'}) sum_tv
(* Record *)
| E_record m ->
let aux prev k expr =
let%bind expr' = type_expression' e expr in
ok (I.LMap.add k expr' prev)
ok (O.LMap.add (convert_label k) expr' prev)
in
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok I.LMap.empty) m in
return (E_record m') (t_record (I.LMap.map get_type_expression m') ())
let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m in
return (E_record m') (t_record (O.LMap.map get_type_expression m') ())
| E_record_update {record; path; update} ->
let path = convert_label path in
let%bind record = type_expression' e record in
let%bind update = type_expression' e update in
let wrapped = get_type_expression record in
let%bind tv =
match wrapped.type_content with
let%bind tv =
match wrapped.type_content with
| T_record record -> (
let field_op = I.LMap.find_opt path record in
let field_op = O.LMap.find_opt path record in
match field_op with
| Some tv -> ok (tv)
| None -> failwith @@ Format.asprintf "field %a is not part of record %a" Stage_common.PP.label path O.PP.type_expression wrapped
| None -> failwith @@ Format.asprintf "field %a is not part of record %a" Ast_typed.PP.label path O.PP.type_expression wrapped
)
| _ -> failwith "Update an expression which is not a record"
in
@ -558,11 +810,11 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
(* this special case is here force annotation of the untyped lambda
generated by pascaligo's for_collect loop *)
let%bind (v_col , v_initr ) = bind_map_pair (type_expression' e) (collect , init_record ) in
let tv_col = get_type_expression v_col in (* this is the type of the collection *)
let tv_col = get_type_expression v_col in (* this is the type of the collection *)
let tv_out = get_type_expression v_initr in (* this is the output type of the lambda*)
let%bind input_type = match tv_col.type_content with
| O.T_operator ( TC_list t | TC_set t) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",t)])
| O.T_operator ( TC_map (k,v)| TC_big_map (k,v)) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
| O.T_operator ( TC_map {k;v}| TC_big_map {k;v}) -> ok @@ make_t_ez_record (("0",tv_out)::[("1",make_t_ez_record [("0",k);("1",v)])])
| _ ->
let wtype = Format.asprintf
"Loops over collections expect lists, sets or maps, got type %a" O.PP.type_expression tv_col in
@ -668,10 +920,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let aux (cur:O.matching_expr) =
match cur with
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = (_ , _ , match_cons, _) } -> [ match_nil ; match_cons ]
| Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
| Match_tuple {vars=_;body;tvs=_} -> [ body ]
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
List.map get_type_expression @@ aux m' in
let aux prec cur =
let%bind () =
@ -750,6 +1002,7 @@ and type_lambda e {
and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =
let name = convert_constant' name in
let%bind typer = Operators.Typer.constant_typers name in
let%bind tv = typer lst tv_opt in
ok(name, tv)
@ -790,7 +1043,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
return (e_literal l)
| E_constant {cons_name;arguments} ->
let%bind lst' = bind_map_list untype_expression arguments in
return (e_constant cons_name lst')
return (e_constant (unconvert_constant' cons_name) lst')
| E_variable n ->
return (e_variable (n))
| E_application {lamb;args} ->
@ -808,17 +1061,17 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
let Constructor n = constructor in
return (e_constructor n p')
| E_record r ->
let r = LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (k,e) -> let%bind e = untype_expression e in ok (k,e)) r in
let r = O.LMap.to_kv_list r in
let%bind r' = bind_map_list (fun (O.Label k,e) -> let%bind e = untype_expression e in ok (I.Label k,e)) r in
return (e_record @@ LMap.of_list r')
| E_record_accessor {record; path} ->
let%bind r' = untype_expression record in
let Label s = path in
return (e_record_accessor r' s)
| E_record_update {record=r; path=l; update=e} ->
| E_record_update {record=r; path=O.Label l; update=e} ->
let%bind r' = untype_expression r in
let%bind e = untype_expression e in
return (e_record_update r' l e)
return (e_record_update r' (I.Label l) e)
| E_matching {matchee;cases} ->
let%bind ae' = untype_expression matchee in
let%bind m' = untype_matching untype_expression cases in
@ -841,22 +1094,22 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ I.Match_tuple ((lst, b),[])
| Match_option {match_none ; match_some = (v, some,_)} ->
| Match_tuple {vars; body;tvs=_} ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f some in
let match_some = v, some, () in
let%bind some = f body in
let match_some = opt, some, () in
ok @@ Match_option {match_none ; match_some}
| Match_list {match_nil ; match_cons = (hd_name, tl_name, cons,_)} ->
| Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} ->
let%bind match_nil = f match_nil in
let%bind cons = f cons in
let match_cons = hd_name , tl_name , cons, () in
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((a,b),c') in
let%bind lst' = bind_map_list aux lst in
| Match_variant {cases;tv=_} ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind c' = f body in
ok ((unconvert_constructor' constructor,pattern),c') in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())

4
src/passes/9-self_ast_typed/contract_passes.ml
View File

@ -1,4 +1,4 @@
open Ast_typed
open Ast_typed.Types
open Trace
type contract_pass_data = {
@ -63,7 +63,7 @@ let self_typing : contract_pass_data -> expression -> (bool * contract_pass_data
| _ -> fail @@ Errors.entrypoint_annotation_not_literal entrypoint_exp.location in
let%bind entrypoint_t = match dat.contract_type.parameter.type_content with
| T_sum cmap -> trace_option (Errors.unmatched_entrypoint entrypoint_exp.location)
@@ Stage_common.Types.CMap.find_opt (Constructor entrypoint) cmap
@@ CMap.find_opt (Constructor entrypoint) cmap
| t -> ok {dat.contract_type.parameter with type_content = t} in
let%bind () =
trace_strong (bad_self_err ()) @@

128
src/passes/9-self_ast_typed/helpers.ml
View File

@ -1,9 +1,9 @@
open Ast_typed
open Trace
open Stage_common.Helpers
open Ast_typed.Helpers
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -51,32 +51,32 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind res = fold_expression f init match_true in
let%bind res = fold_expression f res match_false in
ok res
)
| Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> (
| Match_list { match_nil ; match_cons = {hd=_; tl=_ ; body; tv=_} } -> (
let%bind res = fold_expression f init match_nil in
let%bind res = fold_expression f res cons in
let%bind res = fold_expression f res body in
ok res
)
| Match_option { match_none ; match_some = (_ , some, _) } -> (
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> (
let%bind res = fold_expression f init match_none in
let%bind res = fold_expression f res some in
let%bind res = fold_expression f res body in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
| Match_tuple {vars=_ ; body; tvs=_} -> (
let%bind res = fold_expression f init body in
ok res
)
| Match_variant (lst, _) -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
| Match_variant {cases;tv=_} -> (
let aux init' {constructor=_; pattern=_ ; body} =
let%bind res' = fold_expression f init' body in
ok res' in
let%bind res = bind_fold_list aux init lst in
let%bind res = bind_fold_list aux init cases in
ok res
)
@ -139,42 +139,42 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
let%bind match_true = map_expression f match_true in
let%bind match_false = map_expression f match_false in
ok @@ Match_bool { match_true ; match_false }
)
| Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> (
)
| Match_list { match_nil ; match_cons = {hd ; tl ; body ; tv} } -> (
let%bind match_nil = map_expression f match_nil in
let%bind cons = map_expression f cons in
ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, te) }
let%bind body = map_expression f body in
ok @@ Match_list { match_nil ; match_cons = {hd ; tl ; body; tv} }
)
| Match_option { match_none ; match_some = (name , some, te) } -> (
| Match_option { match_none ; match_some = {opt ; body ; tv } } -> (
let%bind match_none = map_expression f match_none in
let%bind some = map_expression f some in
ok @@ Match_option { match_none ; match_some = (name , some, te) }
let%bind body = map_expression f body in
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
)
| Match_tuple ((names , e), te) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), te)
| Match_tuple { vars ; body ; tvs } -> (
let%bind body = map_expression f body in
ok @@ Match_tuple { vars ; body ; tvs }
)
| Match_variant (lst, te) -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
| Match_variant {cases;tv} -> (
let aux { constructor ; pattern ; body } =
let%bind body = map_expression f body in
ok {constructor;pattern;body}
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', te)
let%bind cases = bind_map_list aux cases in
ok @@ Match_variant {cases ; tv}
)
and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) ->
match x with
| Declaration_constant (n , e , i, env) -> (
let%bind e' = map_expression m e in
ok (Declaration_constant (n , e' , i, env))
| Declaration_constant {binder; expr ; inline ; post_env} -> (
let%bind expr = map_expression m expr in
ok (Declaration_constant {binder; expr ; inline ; post_env})
)
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -228,42 +228,42 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
)
| E_literal _ | E_variable _ as e' -> ok (init', return e')
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind (init, match_true) = fold_map_expression f init match_true in
let%bind (init, match_false) = fold_map_expression f init match_false in
ok @@ (init, Match_bool { match_true ; match_false })
)
| Match_list { match_nil ; match_cons = (hd , tl , cons, te) } -> (
| Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } } -> (
let%bind (init, match_nil) = fold_map_expression f init match_nil in
let%bind (init, cons) = fold_map_expression f init cons in
ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, te) })
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_list { match_nil ; match_cons = { hd ; tl ; body ; tv } })
)
| Match_option { match_none ; match_some = (name , some, te) } -> (
| Match_option { match_none ; match_some = { opt ; body ; tv } } -> (
let%bind (init, match_none) = fold_map_expression f init match_none in
let%bind (init, some) = fold_map_expression f init some in
ok @@ (init, Match_option { match_none ; match_some = (name , some, te) })
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
)
| Match_tuple ((names , e), te) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), te))
| Match_tuple { vars ; body ; tvs } -> (
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_tuple {vars ; body ; tvs })
)
| Match_variant (lst, te) -> (
let aux init ((a , b) , e) =
let%bind (init,e') = fold_map_expression f init e in
ok (init, ((a , b) , e'))
| Match_variant {cases ; tv} -> (
let aux init {constructor ; pattern ; body} =
let%bind (init, body) = fold_map_expression f init body in
ok (init, {constructor; pattern ; body})
in
let%bind (init,lst') = bind_fold_map_list aux init lst in
ok @@ (init, Match_variant (lst', te))
)
let%bind (init,cases) = bind_fold_map_list aux init cases in
ok @@ (init, Match_variant {cases ; tv})
)
and fold_map_program : 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with
| Declaration_constant (v , e , i, env) -> (
let%bind (acc',e') = fold_map_expression m acc e in
let wrap_content = Declaration_constant (v , e' , i, env) in
| Declaration_constant {binder ; expr ; inline ; post_env} -> (
let%bind (acc', expr) = fold_map_expression m acc expr in
let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in
ok (acc', List.append acc_prg [{x with wrap_content}])
)
in
@ -315,28 +315,28 @@ type contract_type = {
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let main_decl = List.rev @@ List.filter
(fun declt ->
let (Declaration_constant (v , _ , _ , _)) = Location.unwrap declt in
String.equal (Var.to_name v) main_fname
let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
String.equal (Var.to_name binder) main_fname
)
program
in
match main_decl with
| (hd::_) -> (
let (Declaration_constant (_,e,_,_)) = Location.unwrap hd in
match e.type_expression.type_content with
let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
let%bind (parameter,storage) = Stage_common.Helpers.get_pair tin in
let%bind (listop,storage') = Stage_common.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop e) @@
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' e) @@
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname e
| _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| _ -> fail @@ Errors.bad_contract_io main_fname e
| _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")

32
src/passes/9-self_ast_typed/no_nested_big_map.ml
View File

@ -15,15 +15,15 @@ end
let rec check_no_nested_bigmap is_in_bigmap e =
match e.type_content with
| T_operator (TC_big_map (_, _)) when is_in_bigmap ->
| T_operator (TC_big_map _) when is_in_bigmap ->
fail @@ Errors.no_nested_bigmap
| T_operator (TC_big_map (key, value)) ->
let%bind _ = check_no_nested_bigmap false key in
let%bind _ = check_no_nested_bigmap true value in
| T_operator (TC_big_map {k ; v}) ->
let%bind _ = check_no_nested_bigmap false k in
let%bind _ = check_no_nested_bigmap true v in
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
| T_operator (TC_map_or_big_map {k ; v}) ->
let%bind _ = check_no_nested_bigmap false k in
let%bind _ = check_no_nested_bigmap true v in
ok ()
| T_operator (TC_contract t)
| T_operator (TC_option t)
@ -31,17 +31,17 @@ let rec check_no_nested_bigmap is_in_bigmap e =
| T_operator (TC_set t) ->
let%bind _ = check_no_nested_bigmap is_in_bigmap t in
ok ()
| T_operator (TC_map (a, b)) ->
let%bind _ = check_no_nested_bigmap is_in_bigmap a in
let%bind _ = check_no_nested_bigmap is_in_bigmap b in
| T_operator (TC_map { k ; v }) ->
let%bind _ = check_no_nested_bigmap is_in_bigmap k in
let%bind _ = check_no_nested_bigmap is_in_bigmap v in
ok ()
| T_operator (TC_arrow (a, b)) ->
let%bind _ = check_no_nested_bigmap false a in
let%bind _ = check_no_nested_bigmap false b in
| T_operator (TC_arrow { type1 ; type2 }) ->
let%bind _ = check_no_nested_bigmap false type1 in
let%bind _ = check_no_nested_bigmap false type2 in
ok ()
| T_operator (TC_michelson_or (a, b)) ->
let%bind _ = check_no_nested_bigmap false a in
let%bind _ = check_no_nested_bigmap false b in
| T_operator (TC_michelson_or {l; r}) ->
let%bind _ = check_no_nested_bigmap false l in
let%bind _ = check_no_nested_bigmap false r in
ok ()
| T_sum s ->
let es = CMap.to_list s in

20
src/passes/9-self_ast_typed/tail_recursion.ml
View File

@ -63,23 +63,23 @@ and check_recursive_call_in_matching = fun n final_path c ->
let%bind _ = check_recursive_call n final_path match_true in
let%bind _ = check_recursive_call n final_path match_false in
ok ()
| Match_list {match_nil;match_cons=(_,_,e,_)} ->
| Match_list {match_nil;match_cons={hd=_;tl=_;body;tv=_}} ->
let%bind _ = check_recursive_call n final_path match_nil in
let%bind _ = check_recursive_call n final_path e in
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_option {match_none; match_some=(_,e,_)} ->
| Match_option {match_none; match_some={opt=_;body;tv=_}} ->
let%bind _ = check_recursive_call n final_path match_none in
let%bind _ = check_recursive_call n final_path e in
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_tuple ((_,e),_) ->
let%bind _ = check_recursive_call n final_path e in
| Match_tuple {vars=_;body;tvs=_} ->
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_variant (l,_) ->
let aux (_,e) =
let%bind _ = check_recursive_call n final_path e in
| Match_variant {cases;tv=_} ->
let aux {constructor=_; pattern=_; body} =
let%bind _ = check_recursive_call n final_path body in
ok ()
in
let%bind _ = bind_map_list aux l in
let%bind _ = bind_map_list aux cases in
ok ()

2
src/passes/operators/operators.ml
View File

@ -595,7 +595,7 @@ module Typer = struct
| C_SELF_ADDRESS -> ok @@ t_self_address;
| C_IMPLICIT_ACCOUNT -> ok @@ t_implicit_account;
| C_SET_DELEGATE -> ok @@ t_set_delegate ;
| c -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Stage_common.PP.constant c
| c -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Ast_typed.PP.constant c
end
let none = typer_0 "NONE" @@ fun tv_opt ->

273
src/stages/4-ast_typed/PP.ml
View File

@ -1,10 +1,245 @@
[@@@coverage exclude_file]
(* open Types
* open Format
* open PP_helpers *)
(* include Stage_common.PP *)
open Types
open Format
open PP_helpers
include Stage_common.PP
include Ast_PP_type(Ast_typed_type_parameter)
let constructor ppf (c:constructor') : unit =
let Constructor c = c in fprintf ppf "%s" c
let label ppf (l:label) : unit =
let Label l = l in fprintf ppf "%s" l
let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m =
assert (Helpers.is_tuple_lmap m);
let lst = Helpers.tuple_of_record m in
let new_pp ppf (_, v) = fprintf ppf "%a" value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
(* Prints records which only contain the consecutive fields
0..(cardinal-1) as tuples *)
let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m
else
fprintf ppf format_record (record_sep value (tag sep_record)) m
let list_sep_d x = list_sep x (tag " ,@ ")
let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT"
| C_UNIT -> fprintf ppf "UNIT"
| C_NIL -> fprintf ppf "NIL"
| C_NOW -> fprintf ppf "NOW"
| C_IS_NAT -> fprintf ppf "IS_NAT"
| C_SOME -> fprintf ppf "SOME"
| C_NONE -> fprintf ppf "NONE"
| C_ASSERTION -> fprintf ppf "ASSERTION"
| C_ASSERT_INFERRED -> fprintf ppf "ASSERT_INFERRED"
| C_FAILWITH -> fprintf ppf "FAILWITH"
| C_UPDATE -> fprintf ppf "UPDATE"
(* Loops *)
| C_ITER -> fprintf ppf "ITER"
| C_FOLD -> fprintf ppf "FOLD"
| C_FOLD_WHILE -> fprintf ppf "FOLD_WHILE"
| C_FOLD_CONTINUE -> fprintf ppf "CONTINUE"
| C_FOLD_STOP -> fprintf ppf "STOP"
| C_LOOP_LEFT -> fprintf ppf "LOOP_LEFT"
| C_LOOP_CONTINUE -> fprintf ppf "LOOP_CONTINUE"
| C_LOOP_STOP -> fprintf ppf "LOOP_STOP"
(* MATH *)
| C_NEG -> fprintf ppf "NEG"
| C_ABS -> fprintf ppf "ABS"
| C_ADD -> fprintf ppf "ADD"
| C_SUB -> fprintf ppf "SUB"
| C_MUL -> fprintf ppf "MUL"
| C_EDIV -> fprintf ppf "EDIV"
| C_DIV -> fprintf ppf "DIV"
| C_MOD -> fprintf ppf "MOD"
(* LOGIC *)
| C_NOT -> fprintf ppf "NOT"
| C_AND -> fprintf ppf "AND"
| C_OR -> fprintf ppf "OR"
| C_XOR -> fprintf ppf "XOR"
| C_LSL -> fprintf ppf "LSL"
| C_LSR -> fprintf ppf "LSR"
(* COMPARATOR *)
| C_EQ -> fprintf ppf "EQ"
| C_NEQ -> fprintf ppf "NEQ"
| C_LT -> fprintf ppf "LT"
| C_GT -> fprintf ppf "GT"
| C_LE -> fprintf ppf "LE"
| C_GE -> fprintf ppf "GE"
(* Bytes/ String *)
| C_SIZE -> fprintf ppf "SIZE"
| C_CONCAT -> fprintf ppf "CONCAT"
| C_SLICE -> fprintf ppf "SLICE"
| C_BYTES_PACK -> fprintf ppf "BYTES_PACK"
| C_BYTES_UNPACK -> fprintf ppf "BYTES_UNPACK"
| C_CONS -> fprintf ppf "CONS"
(* Pair *)
| C_PAIR -> fprintf ppf "PAIR"
| C_CAR -> fprintf ppf "CAR"
| C_CDR -> fprintf ppf "CDR"
| C_LEFT -> fprintf ppf "LEFT"
| C_RIGHT -> fprintf ppf "RIGHT"
(* Set *)
| C_SET_EMPTY -> fprintf ppf "SET_EMPTY"
| C_SET_LITERAL -> fprintf ppf "SET_LITERAL"
| C_SET_ADD -> fprintf ppf "SET_ADD"
| C_SET_REMOVE -> fprintf ppf "SET_REMOVE"
| C_SET_ITER -> fprintf ppf "SET_ITER"
| C_SET_FOLD -> fprintf ppf "SET_FOLD"
| C_SET_MEM -> fprintf ppf "SET_MEM"
(* List *)
| C_LIST_EMPTY -> fprintf ppf "LIST_EMPTY"
| C_LIST_LITERAL -> fprintf ppf "LIST_LITERAL"
| C_LIST_ITER -> fprintf ppf "LIST_ITER"
| C_LIST_MAP -> fprintf ppf "LIST_MAP"
| C_LIST_FOLD -> fprintf ppf "LIST_FOLD"
(* Maps *)
| C_MAP -> fprintf ppf "MAP"
| C_MAP_EMPTY -> fprintf ppf "MAP_EMPTY"
| C_MAP_LITERAL -> fprintf ppf "MAP_LITERAL"
| C_MAP_GET -> fprintf ppf "MAP_GET"
| C_MAP_GET_FORCE -> fprintf ppf "MAP_GET_FORCE"
| C_MAP_ADD -> fprintf ppf "MAP_ADD"
| C_MAP_REMOVE -> fprintf ppf "MAP_REMOVE"
| C_MAP_UPDATE -> fprintf ppf "MAP_UPDATE"
| C_MAP_ITER -> fprintf ppf "MAP_ITER"
| C_MAP_MAP -> fprintf ppf "MAP_MAP"
| C_MAP_FOLD -> fprintf ppf "MAP_FOLD"
| C_MAP_MEM -> fprintf ppf "MAP_MEM"
| C_MAP_FIND -> fprintf ppf "MAP_FIND"
| C_MAP_FIND_OPT -> fprintf ppf "MAP_FIND_OP"
(* Big Maps *)
| C_BIG_MAP -> fprintf ppf "BIG_MAP"
| C_BIG_MAP_EMPTY -> fprintf ppf "BIG_MAP_EMPTY"
| C_BIG_MAP_LITERAL -> fprintf ppf "BIG_MAP_LITERAL"
(* Crypto *)
| C_SHA256 -> fprintf ppf "SHA256"
| C_SHA512 -> fprintf ppf "SHA512"
| C_BLAKE2b -> fprintf ppf "BLAKE2b"
| C_HASH -> fprintf ppf "HASH"
| C_HASH_KEY -> fprintf ppf "HASH_KEY"
| C_CHECK_SIGNATURE -> fprintf ppf "CHECK_SIGNATURE"
| C_CHAIN_ID -> fprintf ppf "CHAIN_ID"
(* Blockchain *)
| C_CALL -> fprintf ppf "CALL"
| C_CONTRACT -> fprintf ppf "CONTRACT"
| C_CONTRACT_OPT -> fprintf ppf "CONTRACT_OPT"
| C_CONTRACT_ENTRYPOINT -> fprintf ppf "CONTRACT_ENTRYPOINT"
| C_CONTRACT_ENTRYPOINT_OPT -> fprintf ppf "CONTRACT_ENTRYPOINT_OPT"
| C_AMOUNT -> fprintf ppf "AMOUNT"
| C_BALANCE -> fprintf ppf "BALANCE"
| C_SOURCE -> fprintf ppf "SOURCE"
| C_SENDER -> fprintf ppf "SENDER"
| C_ADDRESS -> fprintf ppf "ADDRESS"
| C_SELF -> fprintf ppf "SELF"
| C_SELF_ADDRESS -> fprintf ppf "SELF_ADDRESS"
| C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT"
| C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE"
| C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT"
let literal ppf (l : literal) =
match l with
| Literal_unit -> fprintf ppf "unit"
| Literal_void -> fprintf ppf "void"
| Literal_bool b -> fprintf ppf "%b" b
| Literal_int n -> fprintf ppf "%d" n
| Literal_nat n -> fprintf ppf "+%d" n
| Literal_timestamp n -> fprintf ppf "+%d" n
| Literal_mutez n -> fprintf ppf "%dmutez" n
| Literal_string s -> fprintf ppf "%S" s
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
| Literal_address s -> fprintf ppf "@%S" s
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
| Literal_key s -> fprintf ppf "key %s" s
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
| Literal_signature s -> fprintf ppf "Signature %s" s
| Literal_chain_id s -> fprintf ppf "Chain_id %s" s
let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t
and type_constant ppf (tc : type_constant) : unit =
let s =
match tc with
| TC_unit -> "unit"
| TC_string -> "string"
| TC_bytes -> "bytes"
| TC_nat -> "nat"
| TC_int -> "int"
| TC_mutez -> "mutez"
| TC_bool -> "bool"
| TC_operation -> "operation"
| TC_address -> "address"
| TC_key -> "key"
| TC_key_hash -> "key_hash"
| TC_signature -> "signature"
| TC_timestamp -> "timestamp"
| TC_chain_id -> "chain_id"
| TC_void -> "void"
in
fprintf ppf "%s" s
open Format
let rec type_expression' :
(formatter -> type_expression -> unit)
-> formatter
-> type_expression
-> unit =
fun f ppf te ->
match te.type_content with
| T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_expression ppf (te : type_expression) : unit =
type_expression' type_expression ppf te
and type_operator :
(formatter -> type_expression -> unit)
-> formatter
-> type_operator
-> unit =
fun f ppf to_ ->
let s =
match to_ with
| TC_option te -> Format.asprintf "option(%a)" f te
| TC_list te -> Format.asprintf "list(%a)" f te
| TC_set te -> Format.asprintf "set(%a)" f te
| TC_map {k; v} -> Format.asprintf "Map (%a,%a)" f k f v
| TC_big_map {k; v} -> Format.asprintf "Big Map (%a,%a)" f k f v
| TC_map_or_big_map {k; v} -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v
| TC_michelson_or {l; r} -> Format.asprintf "michelson_or (%a,%a)" f l f r
| TC_arrow {type1; type2} -> Format.asprintf "arrow (%a,%a)" f type1 f type2
| TC_contract te -> Format.asprintf "Contract (%a)" f te
in
fprintf ppf "(TO_%s)" s
(* end include Stage_common.PP *)
let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev
@ -46,10 +281,10 @@ and expression_content ppf (ec: expression_content) =
type_expression fun_type
expression_content (E_lambda lambda)
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
and assoc_expression ppf : map_kv -> unit =
fun {k ; v} -> fprintf ppf "%a -> %a" expression k expression v
and single_record_patch ppf ((p, expr) : label * expr) =
and single_record_patch ppf ((p, expr) : label * expression) =
fprintf ppf "%a <- %a" label p expression expr
@ -59,26 +294,26 @@ and option_inline ppf inline =
else
fprintf ppf ""
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_case -> unit =
fun f ppf {constructor=c; pattern; body} ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching_content -> unit = fun f ppf m -> match m with
| Match_tuple ((lst, b),_) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with
| Match_tuple {vars; body; tvs=_} ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
| Match_variant {cases ; tv=_} ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd_name, tl_name, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd_name expression_variable tl_name f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f body
| Match_option {match_none ; match_some = {opt; body; tv=_}} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable opt f body
let declaration ppf (d : declaration) =
match d with
| Declaration_constant (name, expr, inline,_) ->
fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline
| Declaration_constant {binder; expr; inline; post_env=_} ->
fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"

42
src/stages/4-ast_typed/PP_generic.ml Normal file
View File

@ -0,0 +1,42 @@
open Types
open Fold
open Format
let print_program : formatter -> program -> unit = fun ppf p ->
ignore ppf ;
let assert_nostate _ = () in (* (needs_parens, state) = assert (not needs_parens && match state with None -> true | Some _ -> false) in *)
let nostate = false, "" in
let op = {
generic = (fun state info ->
assert_nostate state;
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
false, "{ " ^ String.concat " ; " (List.map (fun (fld : 'x Adt_info.ctor_or_field_instance) -> fld.cf.name ^ " = " ^ snd (fld.cf_continue nostate)) fields) ^ " }"
| VariantInstance { constructor={ cf = { name; is_builtin=_; type_=_ }; cf_continue }; variant=_ } ->
(match cf_continue nostate with
| true, arg -> true, name ^ " (" ^ arg ^ ")"
| false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate)
);
type_variable = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
type_meta = (fun _visitor state type_meta -> assert_nostate state; false , (ignore type_meta;"TODO:TYPE_META")) ;
bool = (fun _visitor state b -> assert_nostate state; false , if b then "true" else "false") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
bytes = (fun _visitor state bytes -> assert_nostate state; false , (ignore bytes;"TODO:BYTES")) ;
packed_internal_operation = (fun _visitor state op -> assert_nostate state; false , (ignore op;"TODO:PACKED_INTERNAL_OPERATION")) ;
expression_variable = (fun _visitor state ev -> assert_nostate state; false , (ignore ev;"TODO:EXPRESSION_VARIABLE")) ;
constructor' = (fun _visitor state c -> assert_nostate state; false , (ignore c;"TODO:CONSTRUCTOR'")) ;
location = (fun _visitor state loc -> assert_nostate state; false , (ignore loc;"TODO:LOCATION'")) ;
label = (fun _visitor state (Label lbl) -> assert_nostate state; true, "Label " ^ lbl) ;
constructor_map = (fun _visitor continue state cmap -> assert_nostate state; false , (ignore (continue,cmap);"TODO:constructor_map")) ;
label_map = (fun _visitor continue state lmap -> assert_nostate state; false , (ignore (continue,lmap);"TODO:label_map")) ;
list = (fun _visitor continue state lst ->
assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
location_wrap = (fun _visitor continue state lwrap -> assert_nostate state; false , (ignore (continue,lwrap);"TODO:location_wrap")) ;
list_ne = (fun _visitor continue state list_ne -> assert_nostate state; false , (ignore (continue,list_ne);"TODO:location_wrap")) ;
} in
let (_ , state) = fold__program op nostate p in
Printf.printf "%s" state

1
src/stages/4-ast_typed/ast_typed.ml
View File

@ -9,6 +9,7 @@ module Misc = struct
include Misc
include Misc_smart
end
module Helpers = Helpers
include Types
include Misc

16
src/stages/4-ast_typed/combinators.ml
View File

@ -62,9 +62,9 @@ let ez_t_record lst ?s () : type_expression =
t_record m ?s ()
let t_pair a b ?s () : type_expression = ez_t_record [(Label "0",a) ; (Label "1",b)] ?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_map_or_big_map key value ?s () = make_t (T_operator (TC_map_or_big_map (key,value))) s
let t_map k v ?s () = make_t (T_operator (TC_map { k ; v })) s
let t_big_map k v ?s () = make_t (T_operator (TC_big_map { k ; v })) s
let t_map_or_big_map k v ?s () = make_t (T_operator (TC_map_or_big_map { k ; v })) 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 =
@ -190,14 +190,14 @@ 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 =
match t.type_content with
| T_operator (TC_map (k,v)) -> ok (k, v)
| T_operator (TC_map_or_big_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 ()
let get_t_big_map (t:type_expression) : (type_expression * type_expression) result =
match t.type_content with
| T_operator (TC_big_map (k,v)) -> ok (k, v)
| T_operator (TC_map_or_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 ()
let get_t_map_key : type_expression -> type_expression result = fun t ->
@ -341,7 +341,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_constant (d, _, _, _) -> d = Var.of_name name
| Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name
in
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p

2
src/stages/4-ast_typed/combinators.mli
View File

@ -126,7 +126,7 @@ val e_chain_id : string -> expression_content
val e_operation : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -> expression_content
val e_lambda : lambda -> expression_content
val e_pair : expression -> expression -> expression_content
val e_application : expression -> expr -> expression_content
val e_application : expression -> expression -> expression_content
val e_variable : expression_variable -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content

8
src/stages/4-ast_typed/dune
View File

@ -1,3 +1,10 @@
(rule
(target generated_fold.ml)
(deps ../adt_generator/generator.raku types.ml)
(action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml)))
; (mode (promote (until-clean)))
)
(library
(name ast_typed)
(public_name ligo.ast_typed)
@ -6,6 +13,7 @@
tezos-utils
ast_core ; Is that a good idea?
stage_common
adt_generator
)
(preprocess
(pps ppx_let bisect_ppx --conditional)

6
src/stages/4-ast_typed/environment.ml
View File

@ -43,12 +43,14 @@ let add_type : type_variable -> type_expression -> t -> t = fun k v -> List.Ne.h
let get_opt : expression_variable -> t -> element option = fun k x -> List.Ne.find_map (Small.get_opt k) x
let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.Ne.find_map (Small.get_type_opt k) x
let get_constructor : constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)
let convert_constructor' (S.Constructor c) = Constructor c
let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)
let aux = fun x ->
let aux = fun {type_variable=_ ; type_} ->
match type_.type_content with
| T_sum m ->
(match CMap.find_opt k m with
(match CMap.find_opt (convert_constructor' k) m with
Some km -> Some (km , type_)
| None -> None)
| _ -> None

2
src/stages/4-ast_typed/environment.mli
View File

@ -14,7 +14,7 @@ val add_ez_ae : expression_variable -> expression -> t -> t
val add_type : type_variable -> type_expression -> t -> t
val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : constructor' -> t -> (type_expression * type_expression) option
val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option
module Small : sig
type t = small_environment

0
src/stages/adt_generator/fold.ml → src/stages/4-ast_typed/fold.ml
View File

165
src/stages/4-ast_typed/helpers.ml Normal file
View File

@ -0,0 +1,165 @@
open Types
open Trace
let map_type_operator f = function
TC_contract x -> TC_contract (f x)
| TC_option x -> TC_option (f x)
| TC_list x -> TC_list (f x)
| TC_set x -> TC_set (f x)
| TC_map {k ; v} -> TC_map { k = f k ; v = f v }
| TC_big_map {k ; v}-> TC_big_map { k = f k ; v = f v }
| TC_map_or_big_map { k ; v }-> TC_map_or_big_map { k = f k ; v = f v }
| TC_michelson_or { l ; r } -> TC_michelson_or { l = f l ; r = f r }
| TC_arrow {type1 ; type2} -> TC_arrow { type1 = f type1 ; type2 = f type2 }
let bind_map_type_operator f = function
TC_contract x -> let%bind x = f x in ok @@ TC_contract x
| TC_option x -> let%bind x = f x in ok @@ TC_option x
| TC_list x -> let%bind x = f x in ok @@ TC_list x
| TC_set x -> let%bind x = f x in ok @@ TC_set x
| TC_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_map {k ; v}
| TC_big_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_big_map {k ; v}
| TC_map_or_big_map {k ; v} -> let%bind k = f k in let%bind v = f v in ok @@ TC_map_or_big_map {k ; v}
| TC_michelson_or {l ; r}-> let%bind l = f l in let%bind r = f r in ok @@ TC_michelson_or {l ; r}
| TC_arrow {type1 ; type2}-> let%bind type1 = f type1 in let%bind type2 = f type2 in ok @@ TC_arrow {type1 ; type2}
let type_operator_name = function
TC_contract _ -> "TC_contract"
| TC_option _ -> "TC_option"
| TC_list _ -> "TC_list"
| TC_set _ -> "TC_set"
| TC_map _ -> "TC_map"
| TC_big_map _ -> "TC_big_map"
| TC_map_or_big_map _ -> "TC_map_or_big_map"
| TC_michelson_or _ -> "TC_michelson_or"
| TC_arrow _ -> "TC_arrow"
let type_expression'_of_string = function
| "TC_contract" , [x] -> ok @@ T_operator(TC_contract x)
| "TC_option" , [x] -> ok @@ T_operator(TC_option x)
| "TC_list" , [x] -> ok @@ T_operator(TC_list x)
| "TC_set" , [x] -> ok @@ T_operator(TC_set x)
| "TC_map" , [k ; v] -> ok @@ T_operator(TC_map { k ; v })
| "TC_big_map" , [k ; v] -> ok @@ T_operator(TC_big_map { k ; v })
| ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ ->
failwith "internal error: wrong number of arguments for type operator"
| "TC_unit" , [] -> ok @@ T_constant(TC_unit)
| "TC_string" , [] -> ok @@ T_constant(TC_string)
| "TC_bytes" , [] -> ok @@ T_constant(TC_bytes)
| "TC_nat" , [] -> ok @@ T_constant(TC_nat)
| "TC_int" , [] -> ok @@ T_constant(TC_int)
| "TC_mutez" , [] -> ok @@ T_constant(TC_mutez)
| "TC_bool" , [] -> ok @@ T_constant(TC_bool)
| "TC_operation" , [] -> ok @@ T_constant(TC_operation)
| "TC_address" , [] -> ok @@ T_constant(TC_address)
| "TC_key" , [] -> ok @@ T_constant(TC_key)
| "TC_key_hash" , [] -> ok @@ T_constant(TC_key_hash)
| "TC_chain_id" , [] -> ok @@ T_constant(TC_chain_id)
| "TC_signature" , [] -> ok @@ T_constant(TC_signature)
| "TC_timestamp" , [] -> ok @@ T_constant(TC_timestamp)
| _, [] ->
failwith "internal error: wrong number of arguments for type constant"
| _ ->
failwith "internal error: unknown type operator"
let string_of_type_operator = function
| TC_contract x -> "TC_contract" , [x]
| TC_option x -> "TC_option" , [x]
| TC_list x -> "TC_list" , [x]
| TC_set x -> "TC_set" , [x]
| TC_map { k ; v } -> "TC_map" , [k ; v]
| TC_big_map { k ; v } -> "TC_big_map" , [k ; v]
| TC_map_or_big_map { k ; v } -> "TC_map_or_big_map" , [k ; v]
| TC_michelson_or { l ; r } -> "TC_michelson_or" , [l ; r]
| TC_arrow { type1 ; type2 } -> "TC_arrow" , [type1 ; type2]
let string_of_type_constant = function
| TC_unit -> "TC_unit", []
| TC_string -> "TC_string", []
| TC_bytes -> "TC_bytes", []
| TC_nat -> "TC_nat", []
| TC_int -> "TC_int", []
| TC_mutez -> "TC_mutez", []
| TC_bool -> "TC_bool", []
| TC_operation -> "TC_operation", []
| TC_address -> "TC_address", []
| TC_key -> "TC_key", []
| TC_key_hash -> "TC_key_hash", []
| TC_chain_id -> "TC_chain_id", []
| TC_signature -> "TC_signature", []
| TC_timestamp -> "TC_timestamp", []
| TC_void -> "TC_void", []
let string_of_type_expression' = function
| T_operator o -> string_of_type_operator o
| T_constant c -> string_of_type_constant c
| T_sum _ | T_record _ | T_arrow _ | T_variable _ ->
failwith "not a type operator or constant"
let bind_lmap (l:_ label_map) =
let open Trace in
let open LMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux l (ok empty)
let bind_cmap (c:_ constructor_map) =
let open Trace in
let open CMap in
let aux k v prev =
prev >>? fun prev' ->
v >>? fun v' ->
ok @@ add k v' prev' in
fold aux c (ok empty)
let bind_fold_lmap f init (lmap:_ LMap.t) =
let open Trace in
let aux k v prev =
prev >>? fun prev' ->
f prev' k v
in
LMap.fold aux lmap init
let bind_map_lmap f map = bind_lmap (LMap.map f map)
let bind_map_cmap f map = bind_cmap (CMap.map f map)
let bind_map_lmapi f map = bind_lmap (LMap.mapi f map)
let bind_map_cmapi f map = bind_cmap (CMap.mapi f map)
let range i j =
let rec aux i j acc = if i >= j then acc else aux i (j-1) (j-1 :: acc) in
aux i j []
let label_range i j =
List.map (fun i -> Label (string_of_int i)) @@ range i j
let is_tuple_lmap m =
List.for_all (fun i -> LMap.mem i m) @@ (label_range 0 (LMap.cardinal m))
let get_pair m =
let open Trace in
match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with
| Some e1, Some e2 -> ok (e1,e2)
| _ -> simple_fail "not a pair"
let tuple_of_record (m: _ LMap.t) =
let aux i =
let label = Label (string_of_int i) in
let opt = LMap.find_opt (label) m in
Option.bind (fun opt -> Some ((label,opt),i+1)) opt
in
Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux
let list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
List.map snd @@ tuple_of_record m
else
List.rev @@ LMap.to_list m
let kv_list_of_record_or_tuple (m: _ LMap.t) =
if (is_tuple_lmap m) then
tuple_of_record m
else
List.rev @@ LMap.to_kv_list m

48
src/stages/4-ast_typed/misc.ml
View File

@ -1,5 +1,6 @@
open Trace
open Types
open Helpers
module Errors = struct
let different_kinds a b () =
@ -53,7 +54,7 @@ module Errors = struct
error ~data title message ()
let different_props_in_record a b ra rb ka kb () =
let names () = if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb then "tuples" else "records" in
let names () = if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb then "tuples" else "records" in
let title () = "different keys in " ^ (names ()) in
let message () = "" in
let data = [
@ -65,8 +66,8 @@ module Errors = struct
error ~data title message ()
let different_kind_record_tuple a b ra rb () =
let name_a () = if Stage_common.Helpers.is_tuple_lmap ra then "tuple" else "record" in
let name_b () = if Stage_common.Helpers.is_tuple_lmap rb then "tuple" else "record" in
let name_a () = if Helpers.is_tuple_lmap ra then "tuple" else "record" in
let name_b () = if Helpers.is_tuple_lmap rb then "tuple" else "record" in
let title () = "different keys in " ^ (name_a ()) ^ " and " ^ (name_b ()) in
let message () = "Expected these two types to be the same, but they're different (one is a " ^ (name_a ()) ^ " and the other is a " ^ (name_b ()) ^ ")" in
let data = [
@ -82,7 +83,7 @@ module Errors = struct
let different_size_records_tuples a b ra rb =
different_size_type
(if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb
(if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb
then "tuples"
else "records")
a b
@ -228,17 +229,17 @@ module Free_variables = struct
and expression : bindings -> expression -> bindings = fun b e ->
expression_content b e.expression_content
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor' * expression_variable) * a) -> bindings = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching_variant_case : (bindings -> expression -> bindings) -> bindings -> matching_content_case -> bindings = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body
and matching : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching_content -> bindings = fun f b m ->
and matching : (bindings -> expression -> bindings) -> bindings -> matching_expr -> bindings = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
| Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } -> union (f b n) (f (union (of_list [hd ; tl]) b) c)
| Match_option { match_none = n ; match_some = (opt, s, _) } -> union (f b n) (f (union (singleton opt) b) s)
| Match_tuple ((lst , a), _) ->
f (union (of_list lst) b) a
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
and matching_expression = fun x -> matching expression x
@ -338,12 +339,13 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
| TC_list la, TC_list lb
| TC_contract la, TC_contract lb
| TC_set la, TC_set lb -> ok @@ ([la], [lb])
| (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_map_or_big_map (ka,va)), (TC_big_map (kb,vb) | TC_map_or_big_map (kb,vb))
-> ok @@ ([ka;va] ,[kb;vb])
| TC_michelson_or (la,ra), TC_michelson_or (lb,rb) -> ok @@ ([la;ra] , [lb;rb])
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _ | TC_michelson_or _ ) -> fail @@ different_operators opa opb
| (TC_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb})
| (TC_big_map {k=ka;v=va} | TC_map_or_big_map {k=ka;v=va}), (TC_big_map {k=kb;v=vb} | TC_map_or_big_map {k=kb;v=vb})
-> ok @@ ([ka;va] ,[kb;vb])
| TC_michelson_or {l=la;r=ra}, TC_michelson_or {l=lb;r=rb} -> ok @@ ([la;ra] , [lb;rb])
| (TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _| TC_michelson_or _ ),
(TC_option _ | TC_list _ | TC_contract _ | TC_set _ | TC_map _ | TC_big_map _ | TC_map_or_big_map _ | TC_arrow _| TC_michelson_or _ )
-> fail @@ different_operators opa opb
in
if List.length lsta <> List.length lstb then
fail @@ different_operator_number_of_arguments opa opb (List.length lsta) (List.length lstb)
@ -369,7 +371,7 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) :
)
| T_sum _, _ -> fail @@ different_kinds a b
| T_record ra, T_record rb
when Stage_common.Helpers.is_tuple_lmap ra <> Stage_common.Helpers.is_tuple_lmap rb -> (
when Helpers.is_tuple_lmap ra <> Helpers.is_tuple_lmap rb -> (
fail @@ different_kind_record_tuple a b ra rb
)
| T_record ra, T_record rb -> (
@ -489,7 +491,7 @@ let rec assert_value_eq (a, b: (expression*expression)) : unit result =
| Some a, Some b -> Some (assert_value_eq (a, b))
| _ -> Some (fail @@ missing_key_in_record_value k)
in
let%bind _all = Stage_common.Helpers.bind_lmap @@ LMap.merge aux sma smb in
let%bind _all = Helpers.bind_lmap @@ LMap.merge aux sma smb in
ok ()
)
| E_record _, _ ->
@ -515,8 +517,8 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in
if (an = Var.of_name name)
let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in
if Var.equal binder (Var.of_name name)
then Some expr
else None
in
@ -525,4 +527,4 @@ let get_entry (lst : program) (name : string) : expression result =
let program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , _, _, post_env) -> post_env
| Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env

28
src/stages/4-ast_typed/misc_smart.ml
View File

@ -2,13 +2,13 @@ open Trace
open Types
open Combinators
open Misc
open Stage_common.Types
(* open Stage_common.Types *)
let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
| Declaration_constant (d , expr, _, _) when d = Var.of_name s -> Some expr
| Declaration_constant { binder; expr; inline=_ ; post_env=_ } when binder = Var.of_name s -> Some expr
| Declaration_constant _ -> None
in
let%bind main =
@ -23,7 +23,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let env =
let aux = fun _ d ->
match d with
| Declaration_constant (_ , _, _, post_env) -> post_env in
| Declaration_constant {binder=_ ; expr= _ ; inline=_ ; post_env } -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in
let result =
@ -86,27 +86,27 @@ module Captured_variables = struct
let b' = union (singleton r.fun_name) b in
expression_content b' env @@ E_lambda r.lambda
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor' * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body
and matching : type a . (bindings -> a -> bindings result) -> bindings -> (a, 'tv) matching_content -> bindings result = fun f b m ->
and matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } ->
let%bind t' = f b t in
let%bind fa' = f b fa in
ok @@ union t' fa'
| Match_list { match_nil = n ; match_cons = (hd, tl, c, _) } ->
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } ->
let%bind n' = f b n in
let%bind c' = f (union (of_list [hd ; tl]) b) c in
let%bind c' = f (union (of_list [hd ; tl]) b) body in
ok @@ union n' c'
| Match_option { match_none = n ; match_some = (opt, s, _) } ->
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } ->
let%bind n' = f b n in
let%bind s' = f (union (singleton opt) b) s in
let%bind s' = f (union (singleton opt) b) body in
ok @@ union n' s'
| Match_tuple ((lst , a),_) ->
f (union (of_list lst) b) a
| Match_variant (lst , _) ->
let%bind lst' = bind_map_list (matching_variant_case f b) lst in
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } ->
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
ok @@ unions lst'
and matching_expression = fun x -> matching expression x

2
src/stages/4-ast_typed/misc_smart.mli
View File

@ -6,7 +6,7 @@ val program_to_main : program -> string -> lambda result
module Captured_variables : sig
type bindings = expression_variable list
val matching : (bindings -> 'a -> bindings result) -> bindings -> ('a, type_expression) matching_content -> bindings result
val matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> bindings result
val matching_expression : bindings -> matching_expr -> bindings result

310
src/stages/4-ast_typed/types.ml
View File

@ -1,17 +1,266 @@
[@@@warning "-30"]
module S = Ast_core
include Stage_common.Types
include Types_utils
module Ast_typed_type_parameter = struct
type type_meta = S.type_expression option
end
type type_constant =
| TC_unit
| TC_string
| TC_bytes
| TC_nat
| TC_int
| TC_mutez
| TC_bool
| TC_operation
| TC_address
| TC_key
| TC_key_hash
| TC_chain_id
| TC_signature
| TC_timestamp
| TC_void
include Ast_generic_type (Ast_typed_type_parameter)
type te_cmap = type_expression constructor_map
and te_lmap = type_expression label_map
type program = declaration Location.wrap list
and type_content =
| T_sum of te_cmap
| T_record of te_lmap
| T_arrow of arrow
| T_variable of type_variable
| T_constant of type_constant
| T_operator of type_operator
and inline = bool
and arrow = {
type1: type_expression;
type2: type_expression;
}
and type_map_args = {
k : type_expression;
v : type_expression;
}
and michelson_or_args = {
l : type_expression;
r : type_expression;
}
and type_operator =
| TC_contract of type_expression
| TC_option of type_expression
| TC_list of type_expression
| TC_set of type_expression
| TC_map of type_map_args
| TC_big_map of type_map_args
| TC_map_or_big_map of type_map_args
| TC_michelson_or of michelson_or_args
| TC_arrow of arrow
and type_expression = {
type_content: type_content;
type_meta: type_meta;
}
type literal =
| Literal_unit
| Literal_bool of bool
| Literal_int of int
| Literal_nat of int
| Literal_timestamp of int
| Literal_mutez of int
| Literal_string of string
| Literal_bytes of bytes
| Literal_address of string
| Literal_signature of string
| Literal_key of string
| Literal_key_hash of string
| Literal_chain_id of string
| Literal_void
| Literal_operation of packed_internal_operation
type matching_content_bool = {
match_true : expression ;
match_false : expression ;
}
and matching_content_cons = {
hd : expression_variable;
tl : expression_variable;
body : expression;
tv : type_expression;
}
and matching_content_list = {
match_nil : expression ;
match_cons : matching_content_cons;
}
and matching_content_some = {
opt : expression_variable ;
body : expression ;
tv : type_expression ;
}
and matching_content_option = {
match_none : expression ;
match_some : matching_content_some ;
}
and expression_variable_list = expression_variable list
and type_expression_list = type_expression list
and matching_content_tuple = {
vars : expression_variable_list ;
body : expression ;
tvs : type_expression_list ;
}
and matching_content_case = {
constructor : constructor' ;
pattern : expression_variable ;
body : expression ;
}
and matching_content_case_list = matching_content_case list
and matching_content_variant = {
cases: matching_content_case_list;
tv: type_expression;
}
and matching_expr =
| Match_bool of matching_content_bool
| Match_list of matching_content_list
| Match_option of matching_content_option
| Match_tuple of matching_content_tuple
| Match_variant of matching_content_variant
and constant' =
| C_INT
| C_UNIT
| C_NIL
| C_NOW
| C_IS_NAT
| C_SOME
| C_NONE
| C_ASSERTION
| C_ASSERT_INFERRED
| C_FAILWITH
| C_UPDATE
(* Loops *)
| C_ITER
| C_FOLD_WHILE
| C_FOLD_CONTINUE
| C_FOLD_STOP
| C_LOOP_LEFT
| C_LOOP_CONTINUE
| C_LOOP_STOP
| C_FOLD
(* MATH *)
| C_NEG
| C_ABS
| C_ADD
| C_SUB
| C_MUL
| C_EDIV
| C_DIV
| C_MOD
(* LOGIC *)
| C_NOT
| C_AND
| C_OR
| C_XOR
| C_LSL
| C_LSR
(* COMPARATOR *)
| C_EQ
| C_NEQ
| C_LT
| C_GT
| C_LE
| C_GE
(* Bytes/ String *)
| C_SIZE
| C_CONCAT
| C_SLICE
| C_BYTES_PACK
| C_BYTES_UNPACK
| C_CONS
(* Pair *)
| C_PAIR
| C_CAR
| C_CDR
| C_LEFT
| C_RIGHT
(* Set *)
| C_SET_EMPTY
| C_SET_LITERAL
| C_SET_ADD
| C_SET_REMOVE
| C_SET_ITER
| C_SET_FOLD
| C_SET_MEM
(* List *)
| C_LIST_EMPTY
| C_LIST_LITERAL
| C_LIST_ITER
| C_LIST_MAP
| C_LIST_FOLD
(* Maps *)
| C_MAP
| C_MAP_EMPTY
| C_MAP_LITERAL
| C_MAP_GET
| C_MAP_GET_FORCE
| C_MAP_ADD
| C_MAP_REMOVE
| C_MAP_UPDATE
| C_MAP_ITER
| C_MAP_MAP
| C_MAP_FOLD
| C_MAP_MEM
| C_MAP_FIND
| C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP
| C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256
| C_SHA512
| C_BLAKE2b
| C_HASH
| C_HASH_KEY
| C_CHECK_SIGNATURE
| C_CHAIN_ID
(* Blockchain *)
| C_CALL
| C_CONTRACT
| C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT
| C_BALANCE
| C_SOURCE
| C_SENDER
| C_ADDRESS
| C_SELF
| C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE
| C_CREATE_CONTRACT
and declaration_loc = declaration location_wrap
and program = declaration_loc list
and declaration_constant = {
binder : expression_variable ;
expr : expression ;
inline : bool ;
post_env : full_environment ;
}
and declaration =
(* A Declaration_constant is described by
@ -19,7 +268,7 @@ and declaration =
* a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
| Declaration_constant of (expression_variable * expression * inline * full_environment)
| Declaration_constant of declaration_constant
(*
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (full_environment * full_environment))
@ -28,11 +277,25 @@ and declaration =
and expression = {
expression_content: expression_content ;
location: Location.t ;
location: location ;
type_expression: type_expression ;
environment: full_environment ;
}
and map_kv = {
k : expression ;
v : expression ;
}
and look_up = {
ds : expression;
ind : expression;
}
and expression_label_map = expression label_map
and map_kv_list = map_kv list
and expression_list = expression list
and expression_content =
(* Base *)
| E_literal of literal
@ -46,16 +309,17 @@ and expression_content =
| E_constructor of constructor (* For user defined constructors *)
| E_matching of matching
(* Record *)
| E_record of expression label_map
| E_record of expression_label_map
| E_record_accessor of record_accessor
| E_record_update of record_update
and constant =
{ cons_name: constant'
; arguments: expression list }
and constant = {
cons_name: constant' ;
arguments: expression_list ;
}
and application = {
lamb: expression ;
lamb: expression ;
args: expression ;
}
@ -70,7 +334,7 @@ and let_in = {
let_binder: expression_variable ;
rhs: expression ;
let_result: expression ;
inline : inline ;
inline : bool ;
}
and recursive = {
@ -95,10 +359,9 @@ and record_update = {
update: expression ;
}
and matching_expr = (expression,type_expression) matching_content
and matching =
{ matchee: expression
; cases: matching_expr
and matching = {
matchee: expression ;
cases: matching_expr ;
}
and ascription = {
@ -143,13 +406,10 @@ and small_environment = {
type_environment: type_environment ;
}
and full_environment = small_environment List.Ne.t
and expr = expression
and texpr = type_expression
and full_environment = small_environment list_ne
and named_type_content = {
type_name : type_variable;
type_value : type_expression;
}

71
src/stages/4-ast_typed/types_utils.ml Normal file
View File

@ -0,0 +1,71 @@
module S = Ast_core
open Simple_utils.Trace
(* include Stage_common.Types *)
(* type expression_
* and expression_variable = expression_ Var.t
* type type_
* and type_variable = type_ Var.t *)
type expression_ = Stage_common.Types.expression_
type expression_variable = Stage_common.Types.expression_variable
type type_ = Stage_common.Types.type_
type type_variable = Stage_common.Types.type_variable
type constructor' =
| Constructor of string
type label =
| Label of string
module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end)
module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end)
type 'a label_map = 'a LMap.t
type 'a constructor_map = 'a CMap.t
type type_meta = S.type_expression option
type 'a location_wrap = 'a Location.wrap
type 'a list_ne = 'a List.Ne.t
type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation
type location = Location.t
type inline = bool
let fold_map__constructor_map : type a new_a state . (state -> a -> (state * new_a) result) -> state -> a constructor_map -> (state * new_a constructor_map) result =
fun f state m ->
let aux k v acc =
let%bind (state , m) = acc in
let%bind (state , new_v) = f state v in
ok (state , CMap.add k new_v m) in
let%bind (state , m) = CMap.fold aux m (ok (state, CMap.empty)) in
ok (state , m)
let fold_map__label_map : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a label_map -> (state * new_a label_map) result =
fun f state m ->
let aux k v acc =
let%bind (state , m) = acc in
let%bind (state , new_v) = f state v in
ok (state , LMap.add k new_v m) in
let%bind (state , m) = LMap.fold aux m (ok (state, LMap.empty)) in
ok (state , m)
let fold_map__list : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list -> (state * new_a list) Simple_utils.Trace.result =
fun f state l ->
let aux acc element =
let%bind state , l = acc in
let%bind (state , new_element) = f state element in ok (state , new_element :: l) in
let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
ok (state , l)
let fold_map__location_wrap : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a location_wrap -> (state * new_a location_wrap) Simple_utils.Trace.result =
fun f state { wrap_content ; location } ->
let%bind ( state , wrap_content ) = f state wrap_content in
ok (state , ({ wrap_content ; location } : new_a location_wrap))
let fold_map__list_ne : type a state new_a . (state -> a -> (state * new_a) result) -> state -> a list_ne -> (state * new_a list_ne) Simple_utils.Trace.result =
fun f state (first , l) ->
let%bind (state , new_first) = f state first in
let aux acc element =
let%bind state , l = acc in
let%bind (state , new_element) = f state element in
ok (state , new_element :: l) in
let%bind (state , l) = List.fold_left aux (ok (state , [])) l in
ok (state , (new_first , l))

2
src/stages/5-mini_c/types.ml
View File

@ -77,7 +77,7 @@ and expression = {
}
and constant = {
cons_name : constant'; (* this is at the end because it is huge *)
cons_name : constant';
arguments : expression list;
}

3
src/stages/adt_generator/adt_generator.ml
View File

@ -1,2 +1 @@
module Amodule = Amodule
module Use_a_fold = Use_a_fold
module Generic = Generic

10
src/stages/adt_generator/amodule_utils.ml
View File

@ -1,10 +0,0 @@
let fold_map_list v state continue =
let aux = fun (lst', state) elt ->
let (elt', state) = continue elt state in
(elt' :: lst' , state) in
List.fold_left aux ([], state) v
let fold_map_option v state continue =
match v with
Some x -> continue x state
| None -> None

20
src/stages/adt_generator/dune
View File

@ -1,24 +1,6 @@
(rule
(target generated_fold.ml)
(deps generator.raku)
(action (with-stdout-to generated_fold.ml (run perl6 ./generator.raku amodule.ml)))
; (mode (promote (until-clean)))
)
; (library
; (name adt_generator)
; (public_name ligo.adt_generator)
; (libraries
; )
; )
(executable
(library
(name adt_generator)
(public_name ligo.adt_generator)
(libraries
)
)
(alias
(name runtest)
(action (run ./adt_generator.exe))
)

212
src/stages/adt_generator/generator.pl
View File

@ -1,212 +0,0 @@
#!/usr/bin/env perl
use strict;
use warnings;
use 5.010;
use Data::Dumper; $Data::Dumper::Useqq = 1; # use double quotes when dumping (we have a few "prime'" names)
sub enumerate { my $i = 0; [map { [ $i++, $_ ] } @{$_[0]}] }
my $moduleName = "A";
my $variant = "_ _variant";
my $record = "_ _ record"; my $true = 1; my $false = 0;
sub poly { $_[0] }
my $adts_raw = [
# typename, kind, fields_or_ctors
["root", $variant, [
# ctor, builtin?, type
["A", $false, "rootA"],
["B", $false, "rootB"],
["C", $true, "string"],
]],
["a", $record, [
# field, builtin?, type
["a1", $false, "ta1"],
["a2", $false, "ta2"],
]],
["ta1", $variant, [
["X", $false, "root"],
["Y", $false, "ta2"],
]],
["ta2", $variant, [
["Z", $false, "ta2"],
["W", $true, "unit"],
]],
# polymorphic type
["rootA", poly("list"),
[
# Position (0..n-1), builtin?, type argument
[0, $false, "a"]
]],
["rootB", poly("list"),
[
# Position (0..n-1), builtin?, type argument
[0, $true, "int"]
]],
];
my $adts = [map {
my ($name , $kind, $ctorsOrFields) = @$_;
{
"name" => $name ,
"newName" => "${name}'" ,
"kind" => $kind ,
"ctorsOrFields" => [map {
my ($cf, $isBuiltin, $type) = @$_;
{
name => $cf ,
newName => "${cf}'" ,
isBuiltin => $isBuiltin ,
type => $type ,
newType => $isBuiltin ? $type : "${type}'"
}
} @$ctorsOrFields],
}
} @$adts_raw];
# print Dumper $adts ;
say "(* This is an auto-generated file. Do not edit. *)";
say "";
say "open ${moduleName}";
say "";
foreach (@{enumerate($adts)}) {
my ($index, $t) = @$_;
my %t = %$t;
my $typeOrAnd = $index == 0 ? "type" : "and";
say "${typeOrAnd} $t{newName} =";
if ($t{kind} eq $variant) {
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say " | $c{newName} of $c{newType}"
}
}
elsif ($t{kind} eq $record) {
say " {";
foreach (@{$t{ctorsOrFields}}) {
my %f = %$_;
say " $f{newName} : $f{newType} ;";
}
say " }";
} else {
print " ";
foreach (@{$t{ctorsOrFields}}) {
my %a = %$_;
print "$a{newType} ";
}
print "$t{kind}";
say "";
}
}
say "";
say "type 'state continue_fold =";
say " {";
foreach (@$adts) {
my %t = %$_;
say " $t{name} : $t{name} -> 'state -> ($t{newName} * 'state) ;";
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say " $t{name}_$c{name} : $c{type} -> 'state -> ($c{newType} * 'state) ;"
}
}
say " }";
say "";
say "type 'state fold_config =";
say " {";
foreach (@$adts) {
my %t = %$_;
say " $t{name} : $t{name} -> 'state -> ('state continue_fold) -> ($t{newName} * 'state) ;";
say " $t{name}_pre_state : $t{name} -> 'state -> 'state ;";
say " $t{name}_post_state : $t{name} -> $t{newName} -> 'state -> 'state ;";
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say " $t{name}_$c{name} : $c{type} -> 'state -> ('state continue_fold) -> ($c{newType} * 'state) ;";
}
}
say " }";
say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->";
say " {";
foreach (@$adts) {
my %t = %$_;
say " $t{name} = fold_$t{name} visitor ;";
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say " $t{name}_$c{name} = fold_$t{name}_$c{name} visitor ;";
}
}
say "}";
say "";
foreach (@$adts) {
my %t = %$_;
say "and fold_$t{name} : type state . state fold_config -> $t{name} -> state -> ($t{newName} * state) = fun visitor x state ->";
say " let continue_fold : state continue_fold = mk_continue_fold visitor in";
say " let state = visitor.$t{name}_pre_state x state in";
say " let (new_x, state) = visitor.$t{name} x state continue_fold in";
say " let state = visitor.$t{name}_post_state x new_x state in";
say " (new_x, state)";
say "";
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say "and fold_$t{name}_$c{name} : type state . state fold_config -> $c{type} -> state -> ($c{newType} * state) = fun visitor x state ->";
say " let continue_fold : state continue_fold = mk_continue_fold visitor in";
say " visitor.$t{name}_$c{name} x state continue_fold";
say "";
}
}
say "let no_op : 'a fold_config = {";
foreach (@$adts) {
my %t = %$_;
say " $t{name} = (fun v state continue ->";
say " match v with";
if ($t{kind} eq $variant) {
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
say " | $c{name} v -> let (v, state) = continue.$t{name}_$c{name} v state in ($c{newName} v, state)";
}
} elsif ($t{kind} eq $record) {
print " { ";
foreach (@{$t{ctorsOrFields}}) {
my %f = %$_;
print "$f{name}; ";
}
say "} ->";
foreach (@{$t{ctorsOrFields}}) {
my %f = %$_;
say " let ($f{newName}, state) = continue.$t{name}_$f{name} $f{name} state in";
}
print " ({ ";
foreach (@{$t{ctorsOrFields}}) {
my %f = %$_;
print "$f{newName}; "
}
say "}, state)";
} else {
print " v -> fold_$t{kind} v state ( ";
print join(", ", map { my %f = %$_; "continue.$t{name}_$f{name}" } @{$t{ctorsOrFields}});
say " )";
}
say " );";
say " $t{name}_pre_state = (fun v state -> ignore v; state) ;";
say " $t{name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;";
foreach (@{$t{ctorsOrFields}}) {
my %c = %$_;
print " $t{name}_$c{name} = (fun v state continue -> ";
if ($c{isBuiltin}) {
print "ignore continue; (v, state)";
} else {
print "continue.$c{type} v state";
}
say ") ;";
}
}
say "}";

171
src/stages/adt_generator/generator.py
View File

@ -1,171 +0,0 @@
#!/usr/bin/env python3
import pprint
moduleName = "A"
variant="_ _variant"
record="_ _record"
def poly(x): return x
adts = [
# typename, kind, fields_or_ctors
("root", variant, [
# ctor, builtin?, type
("A", False, "rootA"),
("B", False, "rootB"),
("C", True, "string"),
]),
("a", record, [
# field, builtin?, type
("a1", False, "ta1"),
("a2", False, "ta2"),
]),
("ta1", variant, [
("X", False, "root"),
("Y", False, "ta2"),
]),
("ta2", variant, [
("Z", False, "ta2"),
("W", True, "unit"),
]),
# polymorphic type
("rootA", poly("list"),
[
# Position (0..n-1), builtin?, type argument
(0, False, "a")
]),
("rootB", poly("list"),
[
# Position (0..n-1), builtin?, type argument
(0, True, "int")
]),
]
from collections import namedtuple
adt = namedtuple('adt', ['name', 'newName', 'kind', 'ctorsOrFields'])
ctorOrField = namedtuple('ctorOrField', ['name', 'newName', 'isBuiltin', 'type_', 'newType'])
adts = [
adt(
name = name,
newName = f"{name}'",
kind = kind,
ctorsOrFields = [
ctorOrField(
name = cf,
newName = f"{cf}'",
isBuiltin = isBuiltin,
type_ = type_,
newType = type_ if isBuiltin else f"{type_}'",
)
for (cf, isBuiltin, type_) in ctors
],
)
for (name, kind, ctors) in adts
]
# pprint.PrettyPrinter(compact=False, indent=4).pprint(adts)
print("(* This is an auto-generated file. Do not edit. *)")
print("")
print("open %s" % moduleName)
print("")
for (index, t) in enumerate(adts):
typeOrAnd = "type" if index == 0 else "and"
print(f"{typeOrAnd} {t.newName} =")
if t.kind == variant:
for c in t.ctorsOrFields:
print(f" | {c.newName} of {c.newType}")
elif t.kind == record:
print(" {")
for f in t.ctorsOrFields:
print(f" {f.newName} : {f.newType} ;")
print(" }")
else:
print(" ", end='')
for a in t.ctorsOrFields:
print(f"{a.newType}", end=' ')
print(t.kind, end='')
print("")
print("")
print(f"type 'state continue_fold =")
print(" {")
for t in adts:
print(f" {t.name} : {t.name} -> 'state -> ({t.newName} * 'state) ;")
for c in t.ctorsOrFields:
print(f" {t.name}_{c.name} : {c.type_} -> 'state -> ({c.newType} * 'state) ;")
print(" }")
print("")
print(f"type 'state fold_config =")
print(" {")
for t in adts:
print(f" {t.name} : {t.name} -> 'state -> ('state continue_fold) -> ({t.newName} * 'state) ;")
print(f" {t.name}_pre_state : {t.name} -> 'state -> 'state ;")
print(f" {t.name}_post_state : {t.name} -> {t.newName} -> 'state -> 'state ;")
for c in t.ctorsOrFields:
print(f" {t.name}_{c.name} : {c.type_} -> 'state -> ('state continue_fold) -> ({c.newType} * 'state) ;")
print(" }")
print("")
print('(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)')
print("let rec mk_continue_fold : type state . state fold_config -> state continue_fold = fun visitor ->")
print(" {")
for t in adts:
print(f" {t.name} = fold_{t.name} visitor ;")
for c in t.ctorsOrFields:
print(f" {t.name}_{c.name} = fold_{t.name}_{c.name} visitor ;")
print("}")
print("")
for t in adts:
print(f"and fold_{t.name} : type state . state fold_config -> {t.name} -> state -> ({t.newName} * state) = fun visitor x state ->")
print(" let continue_fold : state continue_fold = mk_continue_fold visitor in")
print(f" let state = visitor.{t.name}_pre_state x state in")
print(f" let (new_x, state) = visitor.{t.name} x state continue_fold in")
print(f" let state = visitor.{t.name}_post_state x new_x state in")
print(" (new_x, state)")
print("")
for c in t.ctorsOrFields:
print(f"and fold_{t.name}_{c.name} : type state . state fold_config -> {c.type_} -> state -> ({c.newType} * state) = fun visitor x state ->")
print(" let continue_fold : state continue_fold = mk_continue_fold visitor in")
print(f" visitor.{t.name}_{c.name} x state continue_fold")
print("")
print("let no_op : 'a fold_config = {")
for t in adts:
print(f" {t.name} = (fun v state continue ->")
print(" match v with")
if t.kind == variant:
for c in t.ctorsOrFields:
print(f" | {c.name} v -> let (v, state) = continue.{t.name}_{c.name} v state in ({c.newName} v, state)")
elif t.kind == record:
print(" {", end=' ')
for f in t.ctorsOrFields:
print(f"{f.name};", end=' ')
print("} ->")
for f in t.ctorsOrFields:
print(f" let ({f.newName}, state) = continue.{t.name}_{f.name} {f.name} state in")
print(" ({", end=' ')
for f in t.ctorsOrFields:
print(f"{f.newName};", end=' ')
print("}, state)")
else:
print(f" v -> fold_{t.kind} v state (", end=' ')
print(", ".join([f"continue.{t.name}_{f.name}" for f in t.ctorsOrFields]), end='')
print(" )")
print(" );")
print(f" {t.name}_pre_state = (fun v state -> ignore v; state) ;")
print(f" {t.name}_post_state = (fun v new_v state -> ignore (v, new_v); state) ;")
for c in t.ctorsOrFields:
print(f" {t.name}_{c.name} = (fun v state continue ->", end=' ')
if c.isBuiltin:
print("ignore continue; (v, state)", end='')
else:
print(f"continue.{c.type_} v state", end='')
print(") ;")
print("}")

328
src/stages/adt_generator/generator.raku
View File

@ -10,23 +10,32 @@ sub poly { $^type_name }
my $l = @*ARGS[0].IO.lines;
$l = $l.map(*.subst: /^\s+/, "");
$l = $l.list.cache;
my $statement_re = /^((\(\*\s+)?(open|include)\s|\[\@\@\@warning\s)/;
my $statements = $l.grep($statement_re);
$l = $l.grep(none $statement_re);
$statements = $statements.map(*.subst(/^\(\*\s+/, '').subst(/\s+\*\)$/, ''));
$l = $l.cache.map(*.subst: /^type\s+/, "\nand ");
$l = $l.join("\n").split(/\nand\s+/).grep(/./);
# TODO: find a better way to write [\*] (anything but a star), the Raku form I found <-[\*]> is very verbose.
$l = $l.join("\n").subst(/\n+/, "\n", :g); # join lines and remove consecutive newlines
$l = $l.subst(/\s*\(\* ( <-[\*]> | \*+<-[\*\)]> )* \*\)/, '', :g); # discard comments (incl. multi-line comments)
$l = $l.split(/\nand\s+/).grep(/./); # split lines again and preserve nonempty lines
$l = $l.map(*.split("\n"));
$l = $l.map: {
my $ll = $_;
my ($name, $kind) = do given $_[0] {
when /^(\w+)\s*\=$/ { "$/[0]", $variant }
when /^(\w+)\s*\=\s*\{$/ { "$/[0]", $record }
when /^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ { "$/[0]", poly("$/[2]") }
when /^((\w|\')+)\s*\=$/ { "$/[0]", $variant }
when /^((\w|\')+)\s*\=\s*\{$/ { "$/[0]", $record }
when /^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ { "$/[0]", poly("$/[2]") }
default { die "Syntax error when parsing header:" ~ $ll.perl ~ "\n$_" }
};
my $ctorsOrFields = do {
when (/^(\w+)\s*\=\s*(\w+)\s+(\w+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
when (/^((\w|\')+)\s*\=\s*((\w|\')+)\s+((\w|\')+)$/ given $_[0]) { ((0, "$/[1]"),).Seq; }
default {
$_[1..*].grep({ ! /^\}?$/ }).map: {
when /^\|\s*(\w+)\s*of\s+((\'|\w)+)$/ { "$/[0]", "$/[1]" }
when /^(\w+)\s*\:\s*((\'|\w)+)\s*\;$/ { "$/[0]", "$/[1]" }
when /^\|\s*((\w|\')+)\s*of\s+((\w|\')+)$/ { "$/[0]", "$/[1]" }
when /^\|\s*((\w|\')+)$/ { "$/[0]", "" }
when /^((\w|\')+)\s*\:\s*((\w|\')+)\s*\;$/ { "$/[0]", "$/[1]" }
default { die "Syntax error when parsing body:" ~ $ll.perl ~ "\n$_" }
}
};
@ -109,16 +118,16 @@ $l = $l.map: {
my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
{
"name" => $name ,
"newName" => "$name'" ,
"newName" => "{$name}__'" ,
"kind" => $kind ,
"ctorsOrFields" => @(map -> ($cf, $type) {
my $isBuiltin = ! $l.cache.first({ $_<name> eq $type });
my $isBuiltin = (! $type) || (! $l.cache.first({ $_<name> eq $type }));
{
name => $cf ,
newName => "$cf'" ,
newName => "{$cf}__'" ,
isBuiltin => $isBuiltin ,
type => $type ,
newType => $isBuiltin ?? $type !! "$type'"
newType => $isBuiltin ?? "$type" !! "{$type}__'"
}
}, @ctorsOrFields),
}
@ -131,17 +140,32 @@ my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) {
say "(* This is an auto-generated file. Do not edit. *)";
say "";
say "open $moduleName";
say "open {$moduleName}_utils";
say "module Adt_info = Generic.Adt_info";
for $statements -> $statement {
say "$statement"
}
say "type 'a monad = 'a Simple_utils.Trace.result;;";
say "let (>>?) v f = Simple_utils.Trace.bind f v;;";
say "let return v = Simple_utils.Trace.ok v;;";
say "open $moduleName;;";
say "module Adt_info = Adt_generator.Generic.Adt_info;;";
say "";
say "(* must be provided by one of the open or include statements: *)";
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say "let fold_map__$poly : type a new_a state . (state -> a -> (state * new_a) Simple_utils.Trace.result) -> state -> a $poly -> (state * new_a $poly) Simple_utils.Trace.result = fold_map__$poly;;"; }
say "";
for $adts.kv -> $index, $t {
my $typeOrAnd = $index == 0 ?? "type" !! "and";
say "$typeOrAnd $t<newName> =";
if ($t<kind> eq $variant) {
for $t<ctorsOrFields>.list -> $c
{ say " | $c<newName> of $c<newType>" }
for $t<ctorsOrFields>.list -> $c {
given $c<type> {
when '' { say " | $c<newName>" }
default { say " | $c<newName> of $c<newType>" }
}
}
say "";
} elsif ($t<kind> eq $record) {
say ' {';
for $t<ctorsOrFields>.list -> $f
@ -155,71 +179,88 @@ for $adts.kv -> $index, $t {
say "";
}
}
say ";;";
say "";
for $adts.list -> $t {
say "type 'state continue_fold_map__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> ('state * $t<newName>) monad ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> ('state * {$c<newType> || 'unit'}) monad ;" }
say ' };;';
}
say "type 'state continue_fold_map = \{";
for $adts.list -> $t {
say " $t<name> : 'state continue_fold_map__$t<name> ;";
}
say ' };;';
say "";
say "type 'state continue_fold_map =";
say ' {';
for $adts.list -> $t
{ say " $t<name> : $t<name> -> 'state -> ($t<newName> * 'state) ;";
{ say "type 'state fold_map_config__$t<name> = \{";
say " node__$t<name> : 'state -> $t<name> -> 'state continue_fold_map -> ('state * $t<newName>) monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__pre_state : 'state -> $t<name> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
say " node__$t<name>__post_state : 'state -> $t<name> -> $t<newName> -> 'state monad ;"; # (*Adt_info.node_instance_info ->*)
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>_$c<name> : $c<type> -> 'state -> ($c<newType> * 'state) ;" } }
say ' }';
{ say " $t<name>__$c<name> : 'state -> {$c<type> || 'unit'} -> 'state continue_fold_map -> ('state * {$c<newType> || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*)
}
say '};;' }
say "";
say "type 'state fold_map_config =";
say ' {';
for $adts.list -> $t
{ say " $t<name> : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t<newName> * 'state) ;";
say " $t<name>_pre_state : $t<name> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
say " $t<name>_post_state : $t<name> -> $t<newName> -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>_$c<name> : $c<type> -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c<newType> * 'state) ;";
} }
say ' }';
{ say " $t<name> : 'state fold_map_config__$t<name>;" }
say ' };;';
say "";
say "module StringMap = Map.Make(String)";
say "module StringMap = Map.Make(String);;";
say "(* generic folds for nodes *)";
say "type 'state generic_continue_fold_node = \{";
say " continue : 'state -> 'state ;";
say " (* generic folds for each field *)";
say " continue_ctors_or_fields : ('state -> 'state) StringMap.t ;";
say '}';
say '};;';
say "(* map from node names to their generic folds *)";
say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t";
say "type 'state generic_continue_fold = ('state generic_continue_fold_node) StringMap.t;;";
say "";
say "type 'state fold_config =";
say ' {';
say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;";
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin>}).map({$_<type>}).unique -> $builtin
{ say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; }
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $builtin
{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; }
say ' }';
say "(* info for adt $moduleName *)";
print "let rec whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
say " generic : 'state -> 'state Adt_info.node_instance_info -> 'state;";
# look for builtins, filtering out the "implicit unit-like fake argument of emtpy constructors" (represented by '')
for $adts.map({ $_<ctorsOrFields> })[*;*].grep({$_<isBuiltin> && $_<type> ne ''}).map({$_<type>}).unique -> $builtin
{ say " $builtin : 'state fold_config -> 'state -> $builtin -> 'state;"; }
# look for built-in polymorphic types
for $adts.grep({$_<kind> ne $record && $_<kind> ne $variant}).map({$_<kind>}).unique -> $poly
{ say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; }
say ' };;';
say "";
say 'type blahblah = {';
for $adts.list -> $t
{ print "info_$t<name> ; "; }
say "]";
{ say " fold__$t<name> : 'state . blahblah -> 'state fold_config -> 'state -> $t<name> -> 'state;";
for $t<ctorsOrFields>.list -> $c
{ say " fold__$t<name>__$c<name> : 'state . blahblah -> 'state fold_config -> 'state -> { $c<type> || 'unit' } -> 'state;"; } }
say '};;';
# generic programming info about the nodes and fields
say "";
for $adts.list -> $t
{ for $t<ctorsOrFields>.list -> $c
{ say "(* info for field or ctor $t<name>.$c<name> *)";
say "and info_$t<name>_$c<name> : Adt_info.ctor_or_field = \{";
say "let info__$t<name>__$c<name> : Adt_info.ctor_or_field = \{";
say " name = \"$c<name>\";";
say " is_builtin = {$c<isBuiltin> ?? 'true' !! 'false'};";
say " type_ = \"$c<type>\";";
say '}';
say "";
say "and continue_info_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{";
say " cf = info_$t<name>_$c<name>;";
say " cf_continue = fun state -> fold_$t<name>_$c<name> visitor x state;";
say '}';
say "let continue_info__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> {$c<type> || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{";
say " cf = info__$t<name>__$c<name>;";
say " cf_continue = fun state -> blahblah.fold__$t<name>__$c<name> blahblah visitor state x;";
say '};;';
say ""; }
say "(* info for node $t<name> *)";
say "and info_$t<name> : Adt_info.node = \{";
say "let info__$t<name> : Adt_info.node = \{";
my $kind = do given $t<kind> {
when $record { "Record" }
when $variant { "Variant" }
@ -228,29 +269,29 @@ for $adts.list -> $t
say " kind = $kind;";
say " declaration_name = \"$t<name>\";";
print " ctors_or_fields = [ ";
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
say "];";
say '}';
say '};;';
say "";
# TODO: factor out some of the common bits here.
say "and continue_info_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun visitor x ->";
say "let continue_info__$t<name> : type qstate . blahblah -> qstate fold_config -> $t<name> -> qstate Adt_info.instance = fun blahblah visitor x ->";
say '{';
say " instance_declaration_name = \"$t<name>\";";
do given $t<kind> {
when $record {
say ' instance_kind = RecordInstance {';
print " fields = [ ";
for $t<ctorsOrFields>.list -> $c { print "continue_info_$t<name>_$c<name> visitor x.$c<name> ; "; }
for $t<ctorsOrFields>.list -> $c { print "continue_info__$t<name>__$c<name> blahblah visitor x.$c<name> ; "; }
say " ];";
say '};';
}
when $variant {
say ' instance_kind = VariantInstance {';
say " constructor = (match x with";
for $t<ctorsOrFields>.list -> $c { say " | $c<name> v -> continue_info_$t<name>_$c<name> visitor v"; }
for $t<ctorsOrFields>.list -> $c { say " | $c<name> { $c<type> ?? 'v ' !! '' }-> continue_info__$t<name>__$c<name> blahblah visitor { $c<type> ?? 'v' !! '()' }"; }
say " );";
print " variant = [ ";
for $t<ctorsOrFields>.list -> $c { print "info_$t<name>_$c<name> ; "; }
for $t<ctorsOrFields>.list -> $c { print "info__$t<name>__$c<name> ; "; }
say "];";
say '};';
}
@ -262,103 +303,166 @@ for $adts.list -> $t
# polymorphic types so it happens to work but should be fixed.
for $t<ctorsOrFields>.list -> $c { print "\"$c<type>\""; }
say "];";
print " poly_continue = (fun state -> visitor.$_ visitor x (";
print " poly_continue = (fun state -> visitor.$_ visitor (";
print $t<ctorsOrFields>
.map(-> $c { "(fun state x -> (continue_info_$t<name>_$c<name> visitor x).cf_continue state)" })
.map(-> $c { "(fun state x -> (continue_info__$t<name>__$c<name> blahblah visitor x).cf_continue state)" })
.join(", ");
say ") state);";
say ") state x);";
say '};';
}
};
say '}';
say '};;';
say ""; }
# make the "continue" object
say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "and mk_continue_fold_map : type qstate . qstate fold_map_config -> qstate continue_fold_map = fun visitor ->";
say ' {';
say "(* info for adt $moduleName *)";
print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ ";
for $adts.list -> $t
{ say " $t<name> = fold_map_$t<name> visitor ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>_$c<name> = fold_map_$t<name>_$c<name> visitor ;"; } }
say ' }';
say "";
# fold_map functions
say "";
for $adts.list -> $t
{ say "and fold_map_$t<name> : type qstate . qstate fold_map_config -> $t<name> -> qstate -> ($t<newName> * qstate) = fun visitor x state ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
say " let state = visitor.$t<name>_pre_state x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
say " let (new_x, state) = visitor.$t<name> x (*(fun () -> whole_adt_info, info_$t<name>)*) state continue_fold_map in";
say " let state = visitor.$t<name>_post_state x new_x (*(fun () -> whole_adt_info, info_$t<name>)*) state in";
say " (new_x, state)";
say "";
for $t<ctorsOrFields>.list -> $c
{ say "and fold_map_$t<name>_$c<name> : type qstate . qstate fold_map_config -> $c<type> -> qstate -> ($c<newType> * qstate) = fun visitor x state ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in";
say " visitor.$t<name>_$c<name> x (*(fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>)*) state continue_fold_map";
say ""; } }
{ print "info__$t<name> ; "; }
say "];;";
# fold functions
say "";
for $adts.list -> $t
{ say "and fold_$t<name> : type qstate . qstate fold_config -> $t<name> -> qstate -> qstate = fun visitor x state ->";
{ say "let fold__$t<name> : type qstate . blahblah -> qstate fold_config -> qstate -> $t<name> -> qstate = fun blahblah visitor state x ->";
# TODO: add a non-generic continue_fold.
say ' let node_instance_info : qstate Adt_info.node_instance_info = {';
say " adt = whole_adt_info () ;";
say " node_instance = continue_info_$t<name> visitor x";
say " node_instance = continue_info__$t<name> blahblah visitor x";
say ' } in';
# say " let (new_x, state) = visitor.$t<name> x (fun () -> whole_adt_info, info_$t<name>) state continue_fold in";
say " visitor.generic node_instance_info state";
# say " let (state, new_x) = visitor.$t<name>.node__$t<name> x (fun () -> whole_adt_info, info__$t<name>) state continue_fold in";
say " visitor.generic state node_instance_info;;";
say "";
for $t<ctorsOrFields>.list -> $c
{ say "and fold_$t<name>_$c<name> : type qstate . qstate fold_config -> $c<type> -> qstate -> qstate = fun visitor x state ->";
# say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info_$t<name>, continue_info_$t<name>_$c<name> visitor x in";
if ($c<isBuiltin>) {
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c<type> visitor x state in";
{ say "let fold__$t<name>__$c<name> : type qstate . blahblah -> qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun blahblah { $c<type> ?? 'visitor' !! '_visitor' } state { $c<type> ?? 'x' !! '()' } ->";
# say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t<name>, continue_info__$t<name>__$c<name> visitor x in";
if ($c<type> eq '') {
# nothing to do, this constructor has no arguments.
say " ignore blahblah; state;;";
} elsif ($c<isBuiltin>) {
say " ignore blahblah; visitor.$c<type> visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
} else {
say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold_$c<type> visitor x state in";
say " blahblah.fold__$c<type> blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*)
}
say " state";
# say " visitor.$t<name>_$c<name> x (fun () -> whole_adt_info, info_$t<name>, info_$t<name>_$c<name>) state continue_fold";
# say " visitor.$t<name>.$t<name>__$c<name> x (fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>) state continue_fold";
say ""; }
}
say "let no_op : 'a fold_map_config = \{";
say "";
say 'let blahblah : blahblah = {';
for $adts.list -> $t
{ say " $t<name> = (fun v (*_info*) state continue ->";
{ say " fold__$t<name>;";
for $t<ctorsOrFields>.list -> $c
{ say " fold__$t<name>__$c<name>;" } }
say '};;';
# Tying the knot
say "";
for $adts.list -> $t
{ say "let fold__$t<name> : type qstate . qstate fold_config -> qstate -> $t<name> -> qstate = fun visitor state x -> fold__$t<name> blahblah visitor state x;;";
for $t<ctorsOrFields>.list -> $c
{ say "let fold__$t<name>__$c<name> : type qstate . qstate fold_config -> qstate -> { $c<type> || 'unit' } -> qstate = fun visitor state x -> fold__$t<name>__$c<name> blahblah visitor state x;;" } }
say "";
say "type 'state mk_continue_fold_map = \{";
say " fn : 'state mk_continue_fold_map -> 'state fold_map_config -> 'state continue_fold_map";
say '};;';
# fold_map functions
say "";
for $adts.list -> $t
{ say "let _fold_map__$t<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " visitor.$t<name>.node__$t<name>__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " visitor.$t<name>.node__$t<name> state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " visitor.$t<name>.node__$t<name>__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t<name>)*)
say " return (state, new_x);;";
say "";
for $t<ctorsOrFields>.list -> $c
{ say "let _fold_map__$t<name>__$c<name> : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad = fun mk_continue_fold_map visitor state x ->";
say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in";
say " visitor.$t<name>.$t<name>__$c<name> state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t<name>, info__$t<name>__$c<name>)*)
say ""; } }
# make the "continue" object
say "";
say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)';
say "let mk_continue_fold_map : 'state . 'state mk_continue_fold_map = \{ fn = fun self visitor ->";
say ' {';
for $adts.list -> $t
{ say " $t<name> = \{";
say " node__$t<name> = (fun state x -> _fold_map__$t<name> self visitor state x) ;";
for $t<ctorsOrFields>.list -> $c
{ say " $t<name>__$c<name> = (fun state x -> _fold_map__$t<name>__$c<name> self visitor state x) ;"; }
say ' };' }
say ' }';
say '};;';
say "";
# fold_map functions : tying the knot
say "";
for $adts.list -> $t
{ say "let fold_map__$t<name> : type qstate . qstate fold_map_config -> qstate -> $t<name> -> (qstate * $t<newName>) monad =";
say " fun visitor state x -> _fold_map__$t<name> mk_continue_fold_map visitor state x;;";
for $t<ctorsOrFields>.list -> $c
{ say "let fold_map__$t<name>__$c<name> : type qstate . qstate fold_map_config -> qstate -> { $c<type> || 'unit' } -> (qstate * { $c<newType> || 'unit' }) monad =";
say " fun visitor state x -> _fold_map__$t<name>__$c<name> mk_continue_fold_map visitor state x;;"; } }
for $adts.list -> $t
{
say "let no_op_node__$t<name> : type state . state -> $t<name> -> state continue_fold_map -> (state * $t<newName>) monad =";
say " fun state v continue ->"; # (*_info*)
say " match v with";
if ($t<kind> eq $variant) {
for $t<ctorsOrFields>.list -> $c
{ say " | $c<name> v -> let (v, state) = continue.$t<name>_$c<name> v state in ($c<newName> v, state)"; }
{ given $c<type> {
when '' { say " | $c<name> -> continue.$t<name>.$t<name>__$c<name> state () >>? fun (state , ()) -> return (state , $c<newName>)"; }
default { say " | $c<name> v -> continue.$t<name>.$t<name>__$c<name> state v >>? fun (state , v) -> return (state , $c<newName> v)"; } } }
} elsif ($t<kind> eq $record) {
print ' { ';
for $t<ctorsOrFields>.list -> $f
{ print "$f<name>; "; }
say "} ->";
for $t<ctorsOrFields>.list -> $f
{ say " let ($f<newName>, state) = continue.$t<name>_$f<name> $f<name> state in"; }
print ' ({ ';
{ say " continue.$t<name>.$t<name>__$f<name> state $f<name> >>? fun (state , $f<newName>) ->"; }
print ' return (state , ({ ';
for $t<ctorsOrFields>.list -> $f
{ print "$f<newName>; "; }
say '}, state)';
say "\} : $t<newName>))";
} else {
print " v -> fold_map_$t<kind> v state ( ";
print ( "continue.$t<name>_$_<name>" for $t<ctorsOrFields>.list ).join(", ");
say " )";
print " v -> fold_map__$t<kind> ( ";
print ( "continue.$t<name>.$t<name>__$_<name>" for $t<ctorsOrFields>.list ).join(", ");
say " ) state v;;";
}
say " );";
say " $t<name>_pre_state = (fun v (*_info*) state -> ignore v; state) ;";
say " $t<name>_post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;";
}
for $adts.list -> $t
{ say "let no_op__$t<name> : type state . state fold_map_config__$t<name> = \{";
say " node__$t<name> = no_op_node__$t<name>;";
say " node__$t<name>__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*)
say " node__$t<name>__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*)
for $t<ctorsOrFields>.list -> $c
{ print " $t<name>_$c<name> = (fun v (*_info*) state continue -> ";
{ print " $t<name>__$c<name> = (fun state v continue -> "; # (*_info*)
if ($c<isBuiltin>) {
print "ignore continue; (v, state)";
print "ignore continue; return (state , v)";
} else {
print "continue.$c<type> v state";
print "continue.$c<type>.node__$c<type> state v";
}
say ") ;"; } }
say '}';
say ") ;"; }
say ' }' }
say "let no_op : type state . state fold_map_config = \{";
for $adts.list -> $t
{ say " $t<name> = no_op__$t<name>;" }
say '};;';
say "";
for $adts.list -> $t
{ say "let with__$t<name> : _ = (fun node__$t<name> op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name> \} \});;";
say "let with__$t<name>__pre_state : _ = (fun node__$t<name>__pre_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__pre_state \} \});;";
say "let with__$t<name>__post_state : _ = (fun node__$t<name>__post_state op -> \{ op with $t<name> = \{ op.$t<name> with node__$t<name>__post_state \} \});;";
for $t<ctorsOrFields>.list -> $c
{ say "let with__$t<name>__$c<name> : _ = (fun $t<name>__$c<name> op -> \{ op with $t<name> = \{ op.$t<name> with $t<name>__$c<name> \} \});;"; } }

2
src/stages/ligo_interpreter/types.ml
View File

@ -1,4 +1,4 @@
include Stage_common.Types
include Ast_typed.Types
(*types*)
module Env = Map.Make(

8
src/stages/typesystem/core.ml
View File

@ -74,10 +74,10 @@ let type_expression'_of_simple_c_constant = function
| C_option , [x] -> ok @@ Ast_typed.T_operator(TC_option x)
| C_list , [x] -> ok @@ Ast_typed.T_operator(TC_list x)
| C_set , [x] -> ok @@ Ast_typed.T_operator(TC_set x)
| C_map , [x ; y] -> ok @@ Ast_typed.T_operator(TC_map (x , y))
| C_big_map , [x ; y] -> ok @@ Ast_typed.T_operator(TC_big_map (x, y))
| C_michelson_or , [x ; y] -> ok @@ Ast_typed.T_operator(TC_michelson_or (x, y))
| C_arrow , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow (x, y))
| C_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_map {k ; v})
| C_big_map , [k ; v] -> ok @@ Ast_typed.T_operator(TC_big_map {k ; v})
| C_michelson_or , [l ; r] -> ok @@ Ast_typed.T_operator(TC_michelson_or {l ; r})
| C_arrow , [x ; y] -> ok @@ Ast_typed.T_operator(TC_arrow {type1=x ; type2=y})
| C_record , _lst -> ok @@ failwith "records are not supported yet: T_record lst"
| C_variant , _lst -> ok @@ failwith "sums are not supported yet: T_sum lst"
| (C_contract | C_option | C_list | C_set | C_map | C_big_map | C_arrow | C_michelson_or ), _ ->

12
src/stages/typesystem/misc.ml
View File

@ -83,7 +83,7 @@ module Substitution = struct
| None -> ok @@ T.T_variable variable
end
| T.T_operator type_name_and_args ->
let%bind type_name_and_args = T.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in
let%bind type_name_and_args = T.Helpers.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in
ok @@ T.T_operator type_name_and_args
| T.T_arrow _ ->
let _TODO = substs in
@ -204,11 +204,11 @@ module Substitution = struct
and s_declaration : T.declaration w = fun ~substs ->
function
Ast_typed.Declaration_constant (ev,e,i,env) ->
let%bind ev = s_variable ~substs ev in
let%bind e = s_expression ~substs e in
let%bind env = s_full_environment ~substs env in
ok @@ Ast_typed.Declaration_constant (ev, e, i, env)
Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} ->
let%bind binder = s_variable ~substs binder in
let%bind expr = s_expression ~substs expr in
let%bind post_env = s_full_environment ~substs post_env in
ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env}
and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
Trace.bind_map_location (s_declaration ~substs) d

2
src/stages/adt_generator/amodule.ml → src/test/adt_generator/amodule.ml
View File

@ -1,3 +1,5 @@
(* open Amodule_utils *)
type root =
| A of rootA
| B of rootB

14
src/test/adt_generator/amodule_utils.ml Normal file
View File

@ -0,0 +1,14 @@
open Simple_utils.Trace
let fold_map__list continue state v =
let aux = fun acc elt ->
let%bind (state , lst') = acc in
let%bind (state , elt') = continue state elt in
ok (state , elt' :: lst') in
List.fold_left aux (ok (state, [])) v
let fold_map__option continue state v =
match v with
Some x -> continue state x
| None -> ok None

20
src/test/adt_generator/dune Normal file
View File

@ -0,0 +1,20 @@
(rule
(target generated_fold.ml)
(deps ../../../src/stages/adt_generator/generator.raku amodule.ml)
(action (with-stdout-to generated_fold.ml (run perl6 ../../../src/stages/adt_generator/generator.raku amodule.ml)))
; (mode (promote (until-clean)))
)
(executable
(name test_adt_generator)
(public_name ligo.test_adt_generator)
(libraries adt_generator simple-utils)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
)
(alias
(name runtest)
(action (run ./test_adt_generator.exe))
)

1
src/test/adt_generator/fold.ml Normal file
View File

@ -0,0 +1 @@
include Generated_fold

2
src/test/adt_generator/test_adt_generator.ml Normal file
View File

@ -0,0 +1,2 @@
module Amodule = Amodule
module Use_a_fold = Use_a_fold

70
src/stages/adt_generator/use_a_fold.ml → src/test/adt_generator/use_a_fold.ml
View File

@ -1,46 +1,60 @@
open Amodule
open Fold
open Simple_utils.Trace
let (|>) v f = f v
module Errors = struct
let test_fail msg =
let title () = "test failed" in
let message () = msg in
error title message
end
(* TODO: how should we plug these into our test framework? *)
let test (x : unit result) : unit = match x with
| Ok (() , _annotation_thunk) -> ()
| Error err -> failwith (Yojson.Basic.to_string @@ err ())
let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
let op = {
no_op with
a = fun the_a (*_info*) state continue_fold ->
let (a1' , state') = continue_fold.ta1 the_a.a1 state in
let (a2' , state'') = continue_fold.ta2 the_a.a2 state' in
({
a1' = a1' ;
a2' = a2' ;
}, state'' + 1)
} in
let op =
no_op |>
with__a (fun state the_a (*_info*) continue_fold ->
let%bind state, a1__' = continue_fold.ta1.node__ta1 state the_a.a1 in
let%bind state, a2__' = continue_fold.ta2.node__ta2 state the_a.a2 in
ok (state + 1, { a1__' ; a2__' }))
in
let state = 0 in
let (_, state) = fold_map_root op some_root state in
let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else
()
ok ()
let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
let op = { no_op with a_pre_state = fun _the_a (*_info*) state -> state + 1 } in
let op = no_op |>
with__a__pre_state (fun state _the_a (*_info*) -> ok @@ state + 1) in
let state = 0 in
let (_, state) = fold_map_root op some_root state in
let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else
()
ok ()
let () =
test @@
let some_root : root = A [{ a1 = X (A [{ a1 = X (B [1;2;3]) ; a2 = W () ; }]) ; a2 = Z (W ()) ; }] in
let op = { no_op with a_post_state = fun _the_a _new_a (*_info*) state -> state + 1 } in
let op = no_op |> with__a__post_state (fun state _the_a _new_a (*_info*) -> ok @@ state + 1) in
let state = 0 in
let (_, state) = fold_map_root op some_root state in
let%bind (state , _) = fold_map__root op state some_root in
if state != 2 then
failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state)
fail @@ Errors.test_fail (Printf.sprintf "expected folder to count 2 nodes, but it counted %d nodes" state)
else
()
ok ()
(* Test that the same fold_map_config can be ascibed with different 'a type arguments *)
@ -52,7 +66,7 @@ let () =
let assert_nostate (needs_parens, state) = assert (not needs_parens && String.equal state "") in
let nostate = false, "" in
let op = {
generic = (fun info state ->
generic = (fun state info ->
assert_nostate state;
match info.node_instance.instance_kind with
| RecordInstance { fields } ->
@ -63,11 +77,11 @@ let () =
| false, arg -> true, name ^ " " ^ arg)
| PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue nostate)
);
string = (fun _visitor str state -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor () state -> assert_nostate state; false , "()") ;
int = (fun _visitor i state -> assert_nostate state; false , string_of_int i) ;
list = (fun _visitor lst continue state ->
) ;
string = (fun _visitor state str -> assert_nostate state; false , "\"" ^ str ^ "\"") ;
unit = (fun _visitor state () -> assert_nostate state; false , "()") ;
int = (fun _visitor state i -> assert_nostate state; false , string_of_int i) ;
list = (fun _visitor continue state lst ->
assert_nostate state;
false , "[ " ^ String.concat " ; " (List.map snd @@ List.map (continue nostate) lst) ^ " ]") ;
(* generic_ctor_or_field = (fun _info state ->
@ -75,7 +89,7 @@ let () =
* (_, _, { name=_; isBuiltin=_; type_=_; continue }) -> state ^ "ctor_or_field [" ^ (continue "") ^ "]"
* ); *)
} in
let (_ , state) = fold_root op some_root nostate in
let (_ , state) = fold__root op nostate some_root in
let expected = "A [ { a1 = X (A [ { a1 = X (B [ 1 ; 2 ; 3 ]) ; a2 = W () } ]) ; a2 = Z (W ()) } ]" in
if String.equal state expected; then
()

2
src/test/typer_tests.ml
View File

@ -56,7 +56,7 @@ module TestExpressions = struct
let constructor () : unit result =
let variant_foo_bar =
O.[(Constructor "foo", t_int ()); (Constructor "bar", t_string ())]
O.[(Typed.Constructor "foo", t_int ()); (Constructor "bar", t_string ())]
in test_expression
~env:(E.env_sum_type variant_foo_bar)
I.(e_constructor "foo" (e_int 32))