From 516a3a85ff1e951d8bc55a9489ecdbeae7242246 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sat, 21 Mar 2020 19:37:28 +0100 Subject: [PATCH] Inlined stage common in ast_typed (fix OCaml type errors) --- src/passes/10-interpreter/interpreter.ml | 6 +- src/passes/10-transpiler/helpers.ml | 6 +- src/passes/10-transpiler/transpiler.ml | 131 ++++++- src/passes/10-transpiler/untranspiler.ml | 2 +- src/passes/8-typer-new/typer.ml | 325 ++++++++++++++++-- src/passes/8-typer-old/typer.ml | 302 ++++++++++++++-- .../9-self_ast_typed/contract_passes.ml | 4 +- src/passes/9-self_ast_typed/helpers.ml | 6 +- src/passes/operators/operators.ml | 2 +- src/stages/4-ast_typed/PP.ml | 210 +++++------ src/stages/4-ast_typed/ast_typed.ml | 1 + src/stages/4-ast_typed/dune | 7 + src/stages/4-ast_typed/environment.ml | 6 +- src/stages/4-ast_typed/environment.mli | 2 +- src/stages/4-ast_typed/misc.ml | 15 +- src/stages/4-ast_typed/misc_smart.ml | 2 +- src/stages/4-ast_typed/misc_smart.mli | 2 +- src/stages/4-ast_typed/types.ml | 218 ++++-------- src/stages/4-ast_typed/types_utils.ml | 23 ++ src/stages/5-mini_c/types.ml | 2 +- src/stages/adt_generator/dune | 2 +- src/stages/ligo_interpreter/types.ml | 2 +- src/stages/typesystem/misc.ml | 2 +- src/test/typer_tests.ml | 2 +- 24 files changed, 911 insertions(+), 369 deletions(-) create mode 100644 src/stages/4-ast_typed/types_utils.ml diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index f4d930298..d04a6f3fb 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -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" ) @@ -345,7 +345,7 @@ and eval : Ast_typed.expression -> env -> value result let ((_, var) , body) = List.find (fun case -> - let (Constructor c , _) = fst case in + let (Ast_typed.Constructor c , _) = fst case in String.equal matched_c c) case_list in let env' = Env.extend env (var, proj) in diff --git a/src/passes/10-transpiler/helpers.ml b/src/passes/10-transpiler/helpers.ml index 57019eeb5..27a9f94dc 100644 --- a/src/passes/10-transpiler/helpers.ml +++ b/src/passes/10-transpiler/helpers.ml @@ -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" diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 29640ada5..42579a86f 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -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 @@ -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 -> diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 076f958da..85aeabc7f 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -244,7 +244,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 diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 52b8b493c..2b2036122 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -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) = @@ -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 @@ -287,7 +555,7 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_ 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')) + ok (state' , ((convert_constructor' constructor_name , name) , b')) in bind_fold_map_list aux state lst in ok (O.Match_variant (lst' , variant) , state'') @@ -307,17 +575,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 +593,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 -> @@ -482,28 +750,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 @@ -609,7 +879,7 @@ 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_content) = 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 ] @@ -668,7 +938,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 @@ -706,6 +976,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) @@ -815,13 +1086,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 @@ -905,7 +1184,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} -> @@ -921,8 +1200,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 @@ -931,7 +1210,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 @@ -981,6 +1260,6 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - | Match_variant (lst , _) -> let aux ((a,b),c) = let%bind c' = f c in - ok ((a,b),c') in + ok ((unconvert_constructor' a,b),c') in let%bind lst' = bind_map_list aux lst in ok @@ Match_variant (lst',()) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index b75508477..d14eb44ed 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -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 @@ -313,8 +563,8 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ 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 @@ -333,7 +583,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ 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') + ok ((convert_constructor' constructor_name , name) , b') in bind_map_list aux lst in ok (O.Match_variant (lst' , variant)) @@ -355,17 +605,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 +623,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 -> @@ -477,9 +727,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 +744,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 +765,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 @@ -750,6 +1001,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 +1042,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 +1060,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 @@ -857,6 +1109,6 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - | Match_variant (lst , _) -> let aux ((a,b),c) = let%bind c' = f c in - ok ((a,b),c') in + ok ((unconvert_constructor' a,b),c') in let%bind lst' = bind_map_list aux lst in ok @@ Match_variant (lst',()) diff --git a/src/passes/9-self_ast_typed/contract_passes.ml b/src/passes/9-self_ast_typed/contract_passes.ml index c16898146..c47e034dc 100644 --- a/src/passes/9-self_ast_typed/contract_passes.ml +++ b/src/passes/9-self_ast_typed/contract_passes.ml @@ -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 ()) @@ diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index e410786e9..54b92ee5a 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -1,6 +1,6 @@ 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 -> @@ -327,8 +327,8 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f | 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 (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 e) @@ Ast_typed.assert_t_list_operation listop in let%bind () = trace_strong (Errors.expected_same main_fname storage storage' e) @@ diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index cc786c004..9e493d00b 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -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 -> diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index c1857a003..bdc100b63 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -1,7 +1,7 @@ [@@@coverage exclude_file] -open Types -open Format -open PP_helpers +(* open Types + * open Format + * open PP_helpers *) (* include Stage_common.PP *) open Types @@ -17,34 +17,33 @@ let label ppf (l:label) : unit = 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 "%a -> %a" constructor k value v in + let new_pp ppf (k, v) = fprintf ppf "@[%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 (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in + let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in + let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" label k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let tuple_sep value sep ppf m = assert (Helpers.is_tuple_lmap m); - let lst = LMap.to_kv_list m in - let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (_k, v) = fprintf ppf "%a" value v in + 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 (const sep_tuple)) m + fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m else - fprintf ppf format_record (record_sep value (const sep_record)) m + fprintf ppf format_record (record_sep value (tag sep_record)) m -let list_sep_d x = list_sep x (const " , ") -let cmap_sep_d x = cmap_sep x (const " , ") -let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , " -let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * " +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 "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " +let tuple_or_record_sep_type value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -112,6 +111,8 @@ let constant ppf : constant' -> unit = function | 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" @@ -161,123 +162,84 @@ let constant ppf : constant' -> unit = function 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 -module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct - module Agt=Ast_generic_type(PARAMETER) - open Agt - open Format + | 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 +let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t - let rec type_expression' : - (formatter -> type_expression -> unit) - -> formatter - -> type_expression - -> unit = - fun f ppf te -> - match te.type_content with - | T_sum m -> - fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> - fprintf ppf "%a" (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_constant ppf (tc : type_constant) : unit = +let s = + match tc with + | TC_unit -> "unit" + | TC_string -> "string" + | TC_bytes -> "bytes" + | TC_nat -> "nat" + | TC_int -> "int" + | TC_mutez -> "mutez" + | TC_bool -> "bool" + | TC_operation -> "operation" + | TC_address -> "address" + | TC_key -> "key" + | TC_key_hash -> "key_hash" + | TC_signature -> "signature" + | TC_timestamp -> "timestamp" + | TC_chain_id -> "chain_id" + | TC_void -> "void" +in +fprintf ppf "%s" s - and type_expression ppf (te : type_expression) : unit = - type_expression' type_expression ppf te +open Format - 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 +let rec type_expression' : + (formatter -> type_expression -> unit) + -> formatter + -> type_expression + -> unit = + fun f ppf te -> + match te.type_content with + | T_sum m -> fprintf ppf "@[sum[%a]@]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "%a" (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_operator : - (formatter -> type_expression -> unit) +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_michelson_or (l, r) -> Format.asprintf "michelson_or (%a,%a)" f l f r - | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v - | TC_contract te -> Format.asprintf "Contract (%a)" f te - in - fprintf ppf "(TO_%s)" s -end + 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 (k, v) -> Format.asprintf "michelson_or (%a,%a)" f k f v + | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v + | TC_contract te -> Format.asprintf "Contract (%a)" f te + in + fprintf ppf "(TO_%s)" s (* end include Stage_common.PP *) -include Ast_PP_type(Ast_typed_type_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev @@ -336,7 +298,7 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex fun f ppf ((c,n),a) -> fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a -and matching : type a . (formatter -> a -> unit) -> _ -> (a, 'var) matching_content -> unit = fun f ppf m -> match m with +and matching : (formatter -> expression -> unit) -> _ -> 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, _) -> diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml index 2ed4ec59e..1b80a9d04 100644 --- a/src/stages/4-ast_typed/ast_typed.ml +++ b/src/stages/4-ast_typed/ast_typed.ml @@ -9,6 +9,7 @@ module Misc = struct include Misc include Misc_smart end +module Helpers = Helpers include Types include Misc diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune index d33c8dac6..c6451404c 100644 --- a/src/stages/4-ast_typed/dune +++ b/src/stages/4-ast_typed/dune @@ -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) diff --git a/src/stages/4-ast_typed/environment.ml b/src/stages/4-ast_typed/environment.ml index cc0aa2878..2f83a978b 100644 --- a/src/stages/4-ast_typed/environment.ml +++ b/src/stages/4-ast_typed/environment.ml @@ -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 diff --git a/src/stages/4-ast_typed/environment.mli b/src/stages/4-ast_typed/environment.mli index a0615e16b..657552937 100644 --- a/src/stages/4-ast_typed/environment.mli +++ b/src/stages/4-ast_typed/environment.mli @@ -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 diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 6020f9539..89c55cf19 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -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 @@ -231,7 +232,7 @@ module Free_variables = struct 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 : type a . (bindings -> a -> bindings) -> bindings -> (a,'var) matching_content -> bindings = fun f b m -> + and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> 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) @@ -369,7 +370,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 +490,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 _, _ -> diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 06357e07f..382f6b432 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -89,7 +89,7 @@ module Captured_variables = struct 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 : 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_content -> bindings result = fun f b m -> match m with | Match_bool { match_true = t ; match_false = fa } -> let%bind t' = f b t in diff --git a/src/stages/4-ast_typed/misc_smart.mli b/src/stages/4-ast_typed/misc_smart.mli index f723916de..5b043401a 100644 --- a/src/stages/4-ast_typed/misc_smart.mli +++ b/src/stages/4-ast_typed/misc_smart.mli @@ -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_content -> bindings result val matching_expression : bindings -> matching_expr -> bindings result diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index be093157a..751daf385 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -1,24 +1,8 @@ [@@@warning "-30"] -module S = Ast_core +include Types_utils -(* include Stage_common.Types *) -type expression_ -and expression_variable = expression_ Var.t -type type_ -and type_variable = type_ Var.t - - -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 - - and type_constant = +type type_constant = | TC_unit | TC_string | TC_bytes @@ -34,126 +18,36 @@ type 'a constructor_map = 'a CMap.t | TC_signature | TC_timestamp | TC_void -module type AST_PARAMETER_TYPE = sig - type type_meta -end -module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct - open PARAMETER +type type_content = + | T_sum of type_expression constructor_map + | T_record of type_expression label_map + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator - type type_content = - | T_sum of type_expression constructor_map - | T_record of type_expression label_map - | T_arrow of arrow - | T_variable of type_variable - | T_constant of type_constant - | T_operator of type_operator +and arrow = { + type1: type_expression; + type2: type_expression + } - and arrow = {type1: type_expression; type2: type_expression} - - and type_operator = - | TC_contract of type_expression - | TC_option of type_expression - | TC_list of type_expression - | TC_set of type_expression - | TC_map of type_expression * type_expression - | TC_big_map of type_expression * type_expression - | TC_michelson_or of type_expression * type_expression - | TC_arrow of type_expression * type_expression +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_expression * type_expression + | TC_big_map of type_expression * type_expression + | TC_map_or_big_map of type_expression * type_expression + | TC_michelson_or of type_expression * type_expression + | TC_arrow of type_expression * type_expression - and type_expression = {type_content: type_content; type_meta: type_meta} - - 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 (x , y) -> TC_map (f x , f y) - | TC_big_map (x , y)-> TC_big_map (f x , f y) - | TC_arrow (x, y) -> TC_arrow (f x, f y) - - 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 (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y) - | TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y) - | TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y) - - let type_operator_name = function - 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_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" , [x ; y] -> ok @@ T_operator(TC_map (x , y)) - | "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y)) - | ("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 (x , y) -> "TC_map" , [x ; y] - | TC_big_map (x , y) -> "TC_big_map" , [x ; y] - | TC_arrow (x , y) -> "TC_arrow" , [x ; y] - - 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" - -end +and type_expression = { + type_content: type_content; + type_meta: type_meta + } type literal = | Literal_unit @@ -170,23 +64,33 @@ type literal = | Literal_key_hash of string | Literal_chain_id of string | Literal_void - | Literal_operation of - Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -and ('a,'tv) matching_content = - | Match_bool of { - match_true : 'a ; - match_false : 'a ; - } - | Match_list of { - match_nil : 'a ; - match_cons : expression_variable * expression_variable * 'a * 'tv; - } - | Match_option of { - match_none : 'a ; - match_some : expression_variable * 'a * 'tv; - } - | Match_tuple of (expression_variable list * 'a) * 'tv list - | Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv + | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation + +type matching_content_bool = { + match_true : expression ; + match_false : expression ; + } + +and matching_content_list = { + match_nil : expression ; + match_cons : expression_variable * expression_variable * expression * type_expression; + } + +and matching_content_option = { + match_none : expression ; + match_some : expression_variable * expression * type_expression; + } + +and matching_content_tuple = (expression_variable list * expression) * type_expression list + +and matching_content_variant = ((constructor' * expression_variable) * expression) list * type_expression + +and matching_content = + | 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 @@ -254,6 +158,8 @@ and constant' = | C_SET_FOLD | C_SET_MEM (* List *) + | C_LIST_EMPTY + | C_LIST_LITERAL | C_LIST_ITER | C_LIST_MAP | C_LIST_FOLD @@ -301,15 +207,7 @@ and constant' = | C_SET_DELEGATE | C_CREATE_CONTRACT -(* end include Stage_common.Types *) - -module Ast_typed_type_parameter = struct - type type_meta = S.type_expression option -end - -include Ast_generic_type (Ast_typed_type_parameter) - -type program = declaration Location.wrap list +and program = declaration Location.wrap list and inline = bool @@ -395,7 +293,7 @@ and record_update = { update: expression ; } -and matching_expr = (expression,type_expression) matching_content +and matching_expr = matching_content and matching = { matchee: expression ; cases: matching_expr diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml new file mode 100644 index 000000000..8ca8f4a47 --- /dev/null +++ b/src/stages/4-ast_typed/types_utils.ml @@ -0,0 +1,23 @@ +module S = Ast_core + +(* 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 diff --git a/src/stages/5-mini_c/types.ml b/src/stages/5-mini_c/types.ml index 8461df787..05e961573 100644 --- a/src/stages/5-mini_c/types.ml +++ b/src/stages/5-mini_c/types.ml @@ -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; } diff --git a/src/stages/adt_generator/dune b/src/stages/adt_generator/dune index 88b963a4d..4d7d78239 100644 --- a/src/stages/adt_generator/dune +++ b/src/stages/adt_generator/dune @@ -1,6 +1,6 @@ (rule (target generated_fold.ml) - (deps generator.raku) + (deps generator.raku amodule.ml) (action (with-stdout-to generated_fold.ml (run perl6 ./generator.raku amodule.ml))) ; (mode (promote (until-clean))) ) diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml index d2274e9ee..57c65adb9 100644 --- a/src/stages/ligo_interpreter/types.ml +++ b/src/stages/ligo_interpreter/types.ml @@ -1,4 +1,4 @@ -include Stage_common.Types +include Ast_typed.Types (*types*) module Env = Map.Make( diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 6b950eccd..04f582715 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -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 diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index 3943a561e..5b3162a94 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -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))