From b3b8fab26df1026407244c943e3d3b834377846a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Mar 2020 15:30:38 +0100 Subject: [PATCH 01/15] [does not build] Inlined stage common in ast_typed --- src/passes/8-typer-new/typer.ml | 1 + src/stages/4-ast_typed/PP.ml | 275 +++++++++++++++++++++++- src/stages/4-ast_typed/helpers.ml | 165 +++++++++++++++ src/stages/4-ast_typed/misc_smart.ml | 2 +- src/stages/4-ast_typed/types.ml | 302 ++++++++++++++++++++++++++- 5 files changed, 742 insertions(+), 3 deletions(-) create mode 100644 src/stages/4-ast_typed/helpers.ml diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index e252d6617..52b8b493c 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -461,6 +461,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 ) diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 0f1722641..c1857a003 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -3,7 +3,280 @@ open Types open Format open PP_helpers -include Stage_common.PP +(* include Stage_common.PP *) +open Types +open Format +open PP_helpers + +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 "%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 + 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 + 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 + else + fprintf ppf format_record (record_sep value (const 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 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_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 +module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct + module Agt=Ast_generic_type(PARAMETER) + open Agt + open Format + + 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_expression ppf (te : type_expression) : unit = + type_expression' type_expression ppf te + + and type_constant ppf (tc : type_constant) : unit = + let s = + match tc with + | TC_unit -> + "unit" + | TC_string -> + "string" + | TC_bytes -> + "bytes" + | TC_nat -> + "nat" + | TC_int -> + "int" + | TC_mutez -> + "mutez" + | TC_bool -> + "bool" + | TC_operation -> + "operation" + | TC_address -> + "address" + | TC_key -> + "key" + | TC_key_hash -> + "key_hash" + | TC_signature -> + "signature" + | TC_timestamp -> + "timestamp" + | TC_chain_id -> + "chain_id" + | TC_void -> + "void" + in + fprintf ppf "%s" s + + and type_operator : + (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 +(* end include Stage_common.PP *) include Ast_PP_type(Ast_typed_type_parameter) let expression_variable ppf (ev : expression_variable) : unit = diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml new file mode 100644 index 000000000..006cae6cb --- /dev/null +++ b/src/stages/4-ast_typed/helpers.ml @@ -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 (x , y) -> TC_map (f x , f y) + | TC_big_map (x , y)-> TC_big_map (f x , f y) + | TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y) + | TC_michelson_or (x, y) -> TC_michelson_or (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_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y) + | TC_michelson_or (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_michelson_or (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_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" , [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_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] + | TC_michelson_or (x , y) -> "TC_michelson_or" , [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" + +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 diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index b4a0b5095..06357e07f 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -2,7 +2,7 @@ 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 , _) = diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index e267ff03c..be093157a 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -1,7 +1,307 @@ [@@@warning "-30"] module S = Ast_core -include Stage_common.Types + +(* 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 = + | 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 +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 + + 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_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 + +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 + 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 + +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_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 + +(* end include Stage_common.Types *) module Ast_typed_type_parameter = struct type type_meta = S.type_expression option 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 02/15] 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)) From 58fc08b6a7a6b2280a91b10e13722fe9ebcc0f60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 3 Apr 2020 15:20:50 +0200 Subject: [PATCH 03/15] ADT generator: add support for open and include --- src/stages/adt_generator/amodule.ml | 2 ++ src/stages/adt_generator/generator.raku | 11 +++++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/stages/adt_generator/amodule.ml b/src/stages/adt_generator/amodule.ml index 8de6bdb5e..ad8035380 100644 --- a/src/stages/adt_generator/amodule.ml +++ b/src/stages/adt_generator/amodule.ml @@ -1,3 +1,5 @@ +(* open Amodule_utils *) + type root = | A of rootA | B of rootB diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 71ab1286e..f3a5ec6ca 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -10,8 +10,13 @@ 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(/./); +$l = $l.join("\n").subst(/\n+/, "\n").split(/\nand\s+/).grep(/./); $l = $l.map(*.split("\n")); $l = $l.map: { my $ll = $_; @@ -131,8 +136,10 @@ my $adts = (map -> (:$name , :$kind, :@ctorsOrFields) { say "(* This is an auto-generated file. Do not edit. *)"; say ""; +for $statements -> $statement { + say "$statement" +} say "open $moduleName"; -say "open {$moduleName}_utils"; say "module Adt_info = Generic.Adt_info"; say ""; From 79593e6f3eeeb27a92029eb8d1153ef9977d06d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 10 Apr 2020 04:39:44 +0200 Subject: [PATCH 04/15] Turned some of the tuples into records --- src/passes/10-transpiler/transpiler.ml | 14 +++---- src/passes/10-transpiler/untranspiler.ml | 8 ++-- src/passes/8-typer-new/solver.ml | 18 ++++---- src/passes/8-typer-new/typer.ml | 20 ++++----- src/passes/8-typer-old/typer.ml | 14 +++---- .../9-self_ast_typed/no_nested_big_map.ml | 32 +++++++------- src/stages/4-ast_typed/PP.ml | 10 ++--- src/stages/4-ast_typed/combinators.ml | 14 +++---- src/stages/4-ast_typed/helpers.ml | 42 +++++++++---------- src/stages/4-ast_typed/misc.ml | 13 +++--- src/stages/4-ast_typed/types.ml | 20 ++++++--- src/stages/typesystem/core.ml | 8 ++-- 12 files changed, 112 insertions(+), 101 deletions(-) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 42579a86f..93c172572 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -250,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'))) @@ -271,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')) diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 85aeabc7f..1e6b86272 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -150,7 +150,7 @@ 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 @@ -168,7 +168,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul 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 @@ -185,8 +185,8 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul 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 -> diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 81c53ed9a..7f06acc93 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -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) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 2b2036122..e6bd25cc0 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -608,26 +608,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)) @@ -1117,23 +1117,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' ) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index d14eb44ed..6e054ae39 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -638,23 +638,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 @@ -809,11 +809,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 diff --git a/src/passes/9-self_ast_typed/no_nested_big_map.ml b/src/passes/9-self_ast_typed/no_nested_big_map.ml index 364859e2c..f90a9b203 100644 --- a/src/passes/9-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/9-self_ast_typed/no_nested_big_map.ml @@ -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 diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index bdc100b63..e6e828e10 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -231,11 +231,11 @@ and type_operator : | 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_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 diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 2c6e50590..e36524561 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -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 -> diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index 006cae6cb..bb3962846 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -6,22 +6,22 @@ let map_type_operator f = function | 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_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y) - | TC_michelson_or (x, y) -> TC_michelson_or (f x, f y) - | TC_arrow (x, y) -> TC_arrow (f x, f y) + | 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 (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_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y) - | TC_michelson_or (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_michelson_or (x , y) - | TC_arrow (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_arrow (x , y) + | 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" @@ -39,8 +39,8 @@ let type_expression'_of_string = function | "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_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" @@ -64,15 +64,15 @@ let type_expression'_of_string = function 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_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] - | TC_michelson_or (x , y) -> "TC_michelson_or" , [x ; y] - | TC_arrow (x , y) -> "TC_arrow" , [x ; y] + | 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", [] diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 89c55cf19..4c708ad8c 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -339,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) diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 751daf385..48e33f924 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -32,16 +32,26 @@ and arrow = { 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_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 + | 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 = { diff --git a/src/stages/typesystem/core.ml b/src/stages/typesystem/core.ml index fd62f2467..f6e362c3b 100644 --- a/src/stages/typesystem/core.ml +++ b/src/stages/typesystem/core.ml @@ -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 ), _ -> From fcbcea93829ba8a7eddcee66a80d87b545f31abc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 23 Mar 2020 01:19:32 +0100 Subject: [PATCH 05/15] Turned some of the mathcing_content tuples into records --- src/passes/10-interpreter/interpreter.ml | 8 ++--- src/passes/10-transpiler/transpiler.ml | 28 +++++++-------- src/passes/8-typer-new/typer.ml | 30 ++++++++-------- src/passes/8-typer-old/typer.ml | 30 ++++++++-------- src/passes/9-self_ast_typed/helpers.ml | 34 +++++++++---------- src/passes/9-self_ast_typed/tail_recursion.ml | 8 ++--- src/stages/4-ast_typed/PP.ml | 8 ++--- src/stages/4-ast_typed/misc.ml | 4 +-- src/stages/4-ast_typed/misc_smart.ml | 8 ++--- src/stages/4-ast_typed/types.ml | 17 ++++++++-- 10 files changed, 94 insertions(+), 81 deletions(-) diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index d04a6f3fb..cd3bdde40 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -338,8 +338,8 @@ 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) = @@ -355,8 +355,8 @@ and eval : Ast_typed.expression -> env -> value result | 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 diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 93c172572..f44142132 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -517,23 +517,23 @@ 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) ) @@ -638,23 +638,23 @@ 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) ) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index e6bd25cc0..36bc20cbe 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -477,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) @@ -493,8 +493,8 @@ 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'') + 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 ((lst, b),_) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ -882,8 +882,8 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - 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 ] - | Match_option { match_none ; match_some = (_ , match_some, _) } -> [ match_none ; match_some ] + | 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 ((_ , match_tuple), _) -> [ match_tuple ] | Match_variant (lst , _) -> List.map snd lst in List.map get_type_expression @@ aux m' in @@ -1247,15 +1247,15 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - | 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_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) = diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 6e054ae39..96f009733 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -505,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) @@ -521,8 +521,8 @@ 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)}) + let%bind body = f e' b in + ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}}) | Match_tuple ((lst, b),_) -> let%bind t_tuple = trace_strong (match_error ~expected:i ~actual:t loc) @@ -919,8 +919,8 @@ 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_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 ((_ , match_tuple), _) -> [ match_tuple ] | Match_variant (lst , _) -> List.map snd lst in List.map get_type_expression @@ aux m' in @@ -1096,15 +1096,15 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - | 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_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) = diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index 54b92ee5a..4f021e7fc 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -58,14 +58,14 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> 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), _) -> ( @@ -139,16 +139,16 @@ 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 @@ -235,15 +235,15 @@ and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_exp 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 diff --git a/src/passes/9-self_ast_typed/tail_recursion.ml b/src/passes/9-self_ast_typed/tail_recursion.ml index 00847e79f..a448ab8b8 100644 --- a/src/passes/9-self_ast_typed/tail_recursion.ml +++ b/src/passes/9-self_ast_typed/tail_recursion.ml @@ -63,13 +63,13 @@ 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 diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index e6e828e10..7d7b22f6b 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -305,10 +305,10 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_content -> uni fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst | 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 diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 4c708ad8c..f554fae86 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -235,8 +235,8 @@ module Free_variables = struct 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) - | Match_option { match_none = n ; match_some = (opt, s, _) } -> union (f b n) (f (union (singleton opt) b) s) + | 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 ((lst , a), _) -> f (union (of_list lst) b) a | Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 382f6b432..d0d1edaa8 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -95,13 +95,13 @@ module Captured_variables = struct 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 diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 48e33f924..91fc8a5e5 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -81,14 +81,27 @@ type matching_content_bool = { 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 : expression_variable * expression_variable * expression * type_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 : expression_variable * expression * type_expression; + match_some : matching_content_some ; } and matching_content_tuple = (expression_variable list * expression) * type_expression list From 9d25773d6119019284617fcdea3f669b67d1ee49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Mon, 23 Mar 2020 23:52:09 +0100 Subject: [PATCH 06/15] Records in ast_typed for match_variant and declaration_constant --- src/passes/10-interpreter/interpreter.ml | 19 ++-- src/passes/10-transpiler/transpiler.ml | 37 ++++---- src/passes/10-transpiler/untranspiler.ml | 19 ++-- src/passes/8-typer-new/typer.ml | 57 ++++++------ src/passes/8-typer-old/typer.ml | 63 ++++++------- src/passes/9-self_ast_typed/helpers.ml | 88 +++++++++---------- src/passes/9-self_ast_typed/tail_recursion.ml | 12 +-- src/stages/4-ast_typed/PP.ml | 22 ++--- src/stages/4-ast_typed/combinators.ml | 2 +- src/stages/4-ast_typed/misc.ml | 16 ++-- src/stages/4-ast_typed/misc_smart.ml | 16 ++-- src/stages/4-ast_typed/types.ml | 38 +++++++- src/stages/typesystem/misc.ml | 10 +-- 13 files changed, 216 insertions(+), 183 deletions(-) diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index cd3bdde40..537e1b1ca 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -341,14 +341,13 @@ and eval : Ast_typed.expression -> env -> value result 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 (Ast_typed.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 @@ -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 diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index f44142132..ff4b0c626 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -537,10 +537,10 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = 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 @@ -560,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' = @@ -658,10 +660,10 @@ and transpile_recursive {fun_name; fun_type; lambda} = 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 @@ -680,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' = @@ -719,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 = diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index 1e6b86272..a2c2f79d9 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -156,14 +156,13 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul 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' @@ -174,12 +173,12 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul 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 diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 36bc20cbe..0df2e2e4d 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -455,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 = @@ -495,17 +495,17 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_ let e' = Environment.add_ez_binder tl t e' in 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 ((lst, b),_) -> - let%bind t_tuple = + | 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 , _) , _) = @@ -548,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' , ((convert_constructor' 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 @@ -781,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 ; @@ -829,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 @@ -884,8 +885,8 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | 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 ((_ , match_tuple), _) -> [ match_tuple ] - | Match_variant (lst , _) -> List.map snd lst in + | 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 @@ -1244,9 +1245,9 @@ 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_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 body in @@ -1257,9 +1258,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - 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 ((unconvert_constructor' 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',()) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 96f009733..e18361c2f 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -486,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 = @@ -523,17 +523,17 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ let e' = Environment.add_ez_binder tl t e' in let%bind body = f e' b in ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}}) - | Match_tuple ((lst, b),_) -> - let%bind t_tuple = + | 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 , _) , _) = @@ -556,13 +556,13 @@ 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 + @@ 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 -> @@ -576,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 ((convert_constructor' 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 @@ -921,8 +922,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression | Match_bool { match_true ; match_false } -> [ match_true ; match_false ] | 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 ((_ , match_tuple), _) -> [ match_tuple ] - | Match_variant (lst , _) -> List.map snd lst in + | 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 () = @@ -1093,9 +1094,9 @@ 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_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 body in @@ -1106,9 +1107,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr - 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 ((unconvert_constructor' 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',()) diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index 4f021e7fc..f1fcc2194 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -3,7 +3,7 @@ open Trace 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,7 +51,7 @@ 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 @@ -68,15 +68,15 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> 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 ) @@ -150,31 +150,31 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> 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,7 +228,7 @@ 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 @@ -245,25 +245,25 @@ and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_exp 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) = 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) @@ + 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") diff --git a/src/passes/9-self_ast_typed/tail_recursion.ml b/src/passes/9-self_ast_typed/tail_recursion.ml index a448ab8b8..1d478b9df 100644 --- a/src/passes/9-self_ast_typed/tail_recursion.ml +++ b/src/passes/9-self_ast_typed/tail_recursion.ml @@ -71,15 +71,15 @@ and check_recursive_call_in_matching = fun n final_path c -> let%bind _ = check_recursive_call n final_path match_none 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 () diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 7d7b22f6b..5871fd13d 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -281,8 +281,8 @@ 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) = fprintf ppf "%a <- %a" label p expression expr @@ -294,15 +294,15 @@ 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 : (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, _) -> - fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst + | 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; tl; body; tv=_}} -> @@ -312,8 +312,8 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_content -> uni 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 "@[%a@]" diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index e36524561..29ad093c6 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -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 diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index f554fae86..e4941a4ba 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -229,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 : (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; 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 ((lst , a), _) -> - f (union (of_list lst) b) a - | Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst + | 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 @@ -517,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 @@ -527,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 diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index d0d1edaa8..8ff39309a 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -8,7 +8,7 @@ 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,8 +86,8 @@ 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 : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m -> match m with @@ -103,10 +103,10 @@ module Captured_variables = struct let%bind n' = f b n 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 diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 91fc8a5e5..06ba61eba 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -104,9 +104,21 @@ and matching_content_option = { match_some : matching_content_some ; } -and matching_content_tuple = (expression_variable list * expression) * type_expression list +and matching_content_tuple = { + vars : expression_variable list ; + body : expression ; + tvs : type_expression list ; + } -and matching_content_variant = ((constructor' * expression_variable) * expression) list * type_expression +and matching_content_case = { + constructor : constructor' ; + pattern : expression_variable ; + body : expression ; + } +and matching_content_variant = { + cases: matching_content_case list; + tv: type_expression; + } and matching_content = | Match_bool of matching_content_bool @@ -234,13 +246,20 @@ and program = declaration Location.wrap list and inline = bool +and declaration_constant = { + binder : expression_variable ; + expr : expression ; + inline : inline ; + post_env : full_environment ; + } + and declaration = (* A Declaration_constant is described by * a name + a type-annotated expression * 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)) @@ -254,6 +273,17 @@ and expression = { environment: full_environment ; } +and map_kv = { + k : expression ; + v : expression ; + } + +and look_up = { + ds : expression; + ind : expression; + } + + and expression_content = (* Base *) | E_literal of literal @@ -276,7 +306,7 @@ and constant = ; arguments: expression list } and application = { - lamb: expression ; + lamb: expression ; args: expression ; } diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 04f582715..64e9e0ff0 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -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 From ba9441a1342339128fa021800b8b23d744fd5c20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 27 Mar 2020 16:29:40 +0100 Subject: [PATCH 07/15] moved adt_generator tests to a separate folder --- src/stages/adt_generator/adt_generator.ml | 3 +-- src/stages/adt_generator/dune | 20 +------------------ src/stages/adt_generator/generator.raku | 2 +- src/{stages => test}/adt_generator/amodule.ml | 0 .../adt_generator/amodule_utils.ml | 0 src/test/adt_generator/dune | 17 ++++++++++++++++ src/{stages => test}/adt_generator/fold.ml | 0 src/test/adt_generator/test_adt_generator.ml | 2 ++ .../adt_generator/use_a_fold.ml | 0 9 files changed, 22 insertions(+), 22 deletions(-) rename src/{stages => test}/adt_generator/amodule.ml (100%) rename src/{stages => test}/adt_generator/amodule_utils.ml (100%) create mode 100644 src/test/adt_generator/dune rename src/{stages => test}/adt_generator/fold.ml (100%) create mode 100644 src/test/adt_generator/test_adt_generator.ml rename src/{stages => test}/adt_generator/use_a_fold.ml (100%) diff --git a/src/stages/adt_generator/adt_generator.ml b/src/stages/adt_generator/adt_generator.ml index 840fe1b02..f96857f7b 100644 --- a/src/stages/adt_generator/adt_generator.ml +++ b/src/stages/adt_generator/adt_generator.ml @@ -1,2 +1 @@ -module Amodule = Amodule -module Use_a_fold = Use_a_fold +module Generic = Generic diff --git a/src/stages/adt_generator/dune b/src/stages/adt_generator/dune index 4d7d78239..0e1a15f71 100644 --- a/src/stages/adt_generator/dune +++ b/src/stages/adt_generator/dune @@ -1,24 +1,6 @@ -(rule - (target generated_fold.ml) - (deps generator.raku amodule.ml) - (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)) -) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index f3a5ec6ca..555e98f22 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -140,7 +140,7 @@ for $statements -> $statement { say "$statement" } say "open $moduleName"; -say "module Adt_info = Generic.Adt_info"; +say "module Adt_info = Adt_generator.Generic.Adt_info"; say ""; for $adts.kv -> $index, $t { diff --git a/src/stages/adt_generator/amodule.ml b/src/test/adt_generator/amodule.ml similarity index 100% rename from src/stages/adt_generator/amodule.ml rename to src/test/adt_generator/amodule.ml diff --git a/src/stages/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml similarity index 100% rename from src/stages/adt_generator/amodule_utils.ml rename to src/test/adt_generator/amodule_utils.ml diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune new file mode 100644 index 000000000..679b3a0fd --- /dev/null +++ b/src/test/adt_generator/dune @@ -0,0 +1,17 @@ +(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) +) + +(alias + (name runtest) + (action (run ./test_adt_generator.exe)) +) diff --git a/src/stages/adt_generator/fold.ml b/src/test/adt_generator/fold.ml similarity index 100% rename from src/stages/adt_generator/fold.ml rename to src/test/adt_generator/fold.ml diff --git a/src/test/adt_generator/test_adt_generator.ml b/src/test/adt_generator/test_adt_generator.ml new file mode 100644 index 000000000..840fe1b02 --- /dev/null +++ b/src/test/adt_generator/test_adt_generator.ml @@ -0,0 +1,2 @@ +module Amodule = Amodule +module Use_a_fold = Use_a_fold diff --git a/src/stages/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml similarity index 100% rename from src/stages/adt_generator/use_a_fold.ml rename to src/test/adt_generator/use_a_fold.ml From 9639c2f775815f449946a5c31e662bc068218d69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 27 Mar 2020 16:40:48 +0100 Subject: [PATCH 08/15] WIP on making the AST compatibile with the ADT generator --- src/passes/8-typer-new/typer.ml | 2 +- src/stages/4-ast_typed/PP.ml | 4 +- src/stages/4-ast_typed/combinators.mli | 2 +- src/stages/4-ast_typed/dune | 13 +-- src/stages/4-ast_typed/misc.ml | 2 +- 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 | 65 ++++++------ src/stages/4-ast_typed/types_utils.ml | 19 ++++ src/stages/adt_generator/generator.raku | 125 +++++++++++++----------- src/test/adt_generator/amodule_utils.ml | 4 +- src/test/adt_generator/use_a_fold.ml | 21 ++-- 12 files changed, 150 insertions(+), 111 deletions(-) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 0df2e2e4d..a275dda33 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -880,7 +880,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.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 = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 5871fd13d..0b8266a11 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -284,7 +284,7 @@ and expression_content ppf (ec: expression_content) = 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 @@ -298,7 +298,7 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c fun f ppf {constructor=c; pattern; body} -> fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body -and matching : (formatter -> expression -> unit) -> _ -> matching_content -> unit = fun f ppf m -> match m with +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=_} -> diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index 6b865e119..a9eaaf2c9 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -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 diff --git a/src/stages/4-ast_typed/dune b/src/stages/4-ast_typed/dune index c6451404c..7a16fdd2a 100644 --- a/src/stages/4-ast_typed/dune +++ b/src/stages/4-ast_typed/dune @@ -1,9 +1,9 @@ -; (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))) -; ) +(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) @@ -13,6 +13,7 @@ tezos-utils ast_core ; Is that a good idea? stage_common + adt_generator ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index e4941a4ba..152c462dc 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -232,7 +232,7 @@ module Free_variables = struct 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 : (bindings -> expression -> bindings) -> bindings -> 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; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body) diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index 8ff39309a..6b643d742 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 : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } -> f (union (singleton pattern) b) body - and matching : (bindings -> expression -> bindings result) -> bindings -> 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 diff --git a/src/stages/4-ast_typed/misc_smart.mli b/src/stages/4-ast_typed/misc_smart.mli index 5b043401a..52fcb29c4 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 -> expression -> bindings result) -> bindings -> matching_content -> bindings result + val matching : (bindings -> expression -> bindings result) -> bindings -> matching_expr -> 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 06ba61eba..28ffb6644 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -19,9 +19,12 @@ type type_constant = | TC_timestamp | TC_void -type type_content = - | T_sum of type_expression constructor_map - | T_record of type_expression label_map +type te_cmap = type_expression constructor_map +and te_lmap = type_expression label_map + +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 @@ -29,7 +32,7 @@ type type_content = and arrow = { type1: type_expression; - type2: type_expression + type2: type_expression; } and type_map_args = { @@ -56,7 +59,7 @@ and type_operator = and type_expression = { type_content: type_content; - type_meta: type_meta + type_meta: type_meta; } type literal = @@ -74,7 +77,7 @@ 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 + | Literal_operation of packed_internal_operation type matching_content_bool = { match_true : expression ; @@ -104,10 +107,13 @@ and matching_content_option = { 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 ; + vars : expression_variable_list ; body : expression ; - tvs : type_expression list ; + tvs : type_expression_list ; } and matching_content_case = { @@ -115,12 +121,15 @@ and matching_content_case = { pattern : expression_variable ; body : expression ; } + +and matching_content_case_list = matching_content_case list + and matching_content_variant = { - cases: matching_content_case list; + cases: matching_content_case_list; tv: type_expression; } -and matching_content = +and matching_expr = | Match_bool of matching_content_bool | Match_list of matching_content_list | Match_option of matching_content_option @@ -242,14 +251,14 @@ and constant' = | C_SET_DELEGATE | C_CREATE_CONTRACT -and program = declaration Location.wrap list +and declaration_loc = declaration location_wrap -and inline = bool +and program = declaration_loc list and declaration_constant = { binder : expression_variable ; expr : expression ; - inline : inline ; + inline : bool ; post_env : full_environment ; } @@ -268,7 +277,7 @@ and declaration = and expression = { expression_content: expression_content ; - location: Location.t ; + location: location ; type_expression: type_expression ; environment: full_environment ; } @@ -283,6 +292,9 @@ and look_up = { 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 *) @@ -297,13 +309,14 @@ 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 ; @@ -321,7 +334,7 @@ and let_in = { let_binder: expression_variable ; rhs: expression ; let_result: expression ; - inline : inline ; + inline : bool ; } and recursive = { @@ -346,10 +359,9 @@ and record_update = { update: expression ; } -and matching_expr = matching_content -and matching = - { matchee: expression - ; cases: matching_expr +and matching = { + matchee: expression ; + cases: matching_expr ; } and ascription = { @@ -394,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; } + diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 8ca8f4a47..d7d9aa61c 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -21,3 +21,22 @@ module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = 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 : 'a . 'a constructor_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a constructor_map * 'state = fun _ _ _ -> failwith "TODO fold_map__constructor_map" + +let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = fun _ _ _ -> failwith "TODO fold_map__label_map" + +let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = fun l state f -> + let aux (state, l) element = let (new_element, state) = f element state in (state, new_element::l) in + let (state, l) = List.fold_left aux (state, []) l in + (l, state) + +let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" + +let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 555e98f22..6430e0773 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -16,22 +16,26 @@ 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").subst(/\n+/, "\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$_" } } }; @@ -114,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({ $_ eq $type }); + my $isBuiltin = (! $type) || (! $l.cache.first({ $_ eq $type })); { name => $cf , - newName => "$cf'" , + newName => "{$cf}__'" , isBuiltin => $isBuiltin , type => $type , - newType => $isBuiltin ?? $type !! "$type'" + newType => $isBuiltin ?? "$type" !! "{$type}__'" } }, @ctorsOrFields), } @@ -147,8 +151,12 @@ for $adts.kv -> $index, $t { my $typeOrAnd = $index == 0 ?? "type" !! "and"; say "$typeOrAnd $t ="; if ($t eq $variant) { - for $t.list -> $c - { say " | $c of $c" } + for $t.list -> $c { + given $c { + when '' { say " | $c" } + default { say " | $c of $c" } + } + } } elsif ($t eq $record) { say ' {'; for $t.list -> $f @@ -166,10 +174,11 @@ for $adts.kv -> $index, $t { say ""; say "type 'state continue_fold_map ="; say ' {'; -for $adts.list -> $t -{ say " $t : $t -> 'state -> ($t * 'state) ;"; - for $t.list -> $c - { say " $t_$c : $c -> 'state -> ($c * 'state) ;" } } +for $adts.list -> $t { + say " $t : $t -> 'state -> ($t * 'state) ;"; + for $t.list -> $c + { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } +} say ' }'; say ""; @@ -177,10 +186,10 @@ say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t { say " $t : $t -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t * 'state) ;"; - say " $t_pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; - say " $t_post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + say " $t__pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + say " $t__post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; for $t.list -> $c - { say " $t_$c : $c -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ($c * 'state) ;"; + { say " $t__$c : {$c || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c || 'unit'} * 'state) ;"; } } say ' }'; @@ -198,7 +207,7 @@ say ""; say "type 'state fold_config ="; say ' {'; say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;"; -for $adts.map({ $_ })[*;*].grep({$_}).map({$_}).unique -> $builtin +for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin { say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; } for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $builtin { say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; } @@ -206,7 +215,7 @@ say ' }'; say "(* info for adt $moduleName *)"; print "let rec whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; for $adts.list -> $t -{ print "info_$t ; "; } +{ print "info__$t ; "; } say "]"; # generic programming info about the nodes and fields @@ -214,19 +223,19 @@ say ""; for $adts.list -> $t { for $t.list -> $c { say "(* info for field or ctor $t.$c *)"; - say "and info_$t_$c : Adt_info.ctor_or_field = \{"; + say "and info__$t__$c : Adt_info.ctor_or_field = \{"; say " name = \"$c\";"; say " is_builtin = {$c ?? 'true' !! 'false'};"; say " type_ = \"$c\";"; say '}'; say ""; - say "and continue_info_$t_$c : type qstate . qstate fold_config -> $c -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{"; - say " cf = info_$t_$c;"; - say " cf_continue = fun state -> fold_$t_$c visitor x state;"; + say "and continue_info__$t__$c : type qstate . qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{"; + say " cf = info__$t__$c;"; + say " cf_continue = fun state -> fold__$t__$c visitor x state;"; say '}'; say ""; } say "(* info for node $t *)"; - say "and info_$t : Adt_info.node = \{"; + say "and info__$t : Adt_info.node = \{"; my $kind = do given $t { when $record { "Record" } when $variant { "Variant" } @@ -235,29 +244,29 @@ for $adts.list -> $t say " kind = $kind;"; say " declaration_name = \"$t\";"; print " ctors_or_fields = [ "; - for $t.list -> $c { print "info_$t_$c ; "; } + for $t.list -> $c { print "info__$t__$c ; "; } say "];"; say '}'; say ""; # TODO: factor out some of the common bits here. - say "and continue_info_$t : type qstate . qstate fold_config -> $t -> qstate Adt_info.instance = fun visitor x ->"; + say "and continue_info__$t : type qstate . qstate fold_config -> $t -> qstate Adt_info.instance = fun visitor x ->"; say '{'; say " instance_declaration_name = \"$t\";"; do given $t { when $record { say ' instance_kind = RecordInstance {'; print " fields = [ "; - for $t.list -> $c { print "continue_info_$t_$c visitor x.$c ; "; } + for $t.list -> $c { print "continue_info__$t__$c visitor x.$c ; "; } say " ];"; say '};'; } when $variant { say ' instance_kind = VariantInstance {'; say " constructor = (match x with"; - for $t.list -> $c { say " | $c v -> continue_info_$t_$c visitor v"; } + for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c visitor { $c ?? 'v' !! '()' }"; } say " );"; print " variant = [ "; - for $t.list -> $c { print "info_$t_$c ; "; } + for $t.list -> $c { print "info__$t__$c ; "; } say "];"; say '};'; } @@ -271,7 +280,7 @@ for $adts.list -> $t say "];"; print " poly_continue = (fun state -> visitor.$_ visitor x ("; print $t - .map(-> $c { "(fun state x -> (continue_info_$t_$c visitor x).cf_continue state)" }) + .map(-> $c { "(fun state x -> (continue_info__$t__$c visitor x).cf_continue state)" }) .join(", "); say ") state);"; say '};'; @@ -286,51 +295,53 @@ say '(* Curries the "visitor" argument to the folds (non-customizable traversal say "and mk_continue_fold_map : type qstate . qstate fold_map_config -> qstate continue_fold_map = fun visitor ->"; say ' {'; for $adts.list -> $t -{ say " $t = fold_map_$t visitor ;"; +{ say " $t = fold_map__$t visitor ;"; for $t.list -> $c - { say " $t_$c = fold_map_$t_$c visitor ;"; } } + { say " $t__$c = fold_map__$t__$c visitor ;"; } } say ' }'; say ""; # fold_map functions say ""; for $adts.list -> $t -{ say "and fold_map_$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state ->"; +{ say "and fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * 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_pre_state x (*(fun () -> whole_adt_info, info_$t)*) state in"; - say " let (new_x, state) = visitor.$t x (*(fun () -> whole_adt_info, info_$t)*) state continue_fold_map in"; - say " let state = visitor.$t_post_state x new_x (*(fun () -> whole_adt_info, info_$t)*) state in"; + say " let state = visitor.$t__pre_state x (*(fun () -> whole_adt_info, info__$t)*) state in"; + say " let (new_x, state) = visitor.$t x (*(fun () -> whole_adt_info, info__$t)*) state continue_fold_map in"; + say " let state = visitor.$t__post_state x new_x (*(fun () -> whole_adt_info, info__$t)*) state in"; say " (new_x, state)"; say ""; for $t.list -> $c - { say "and fold_map_$t_$c : type qstate . qstate fold_map_config -> $c -> qstate -> ($c * qstate) = fun visitor x state ->"; + { say "and fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state ->"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in"; - say " visitor.$t_$c x (*(fun () -> whole_adt_info, info_$t, info_$t_$c)*) state continue_fold_map"; + say " visitor.$t__$c x (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) state continue_fold_map"; say ""; } } # fold functions say ""; for $adts.list -> $t -{ say "and fold_$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state ->"; +{ say "and fold__$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state ->"; # 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 visitor x"; + say " node_instance = continue_info__$t visitor x"; say ' } in'; - # say " let (new_x, state) = visitor.$t x (fun () -> whole_adt_info, info_$t) state continue_fold in"; + # say " let (new_x, state) = visitor.$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; say " visitor.generic node_instance_info state"; say ""; for $t.list -> $c - { say "and fold_$t_$c : type qstate . qstate fold_config -> $c -> 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, continue_info_$t_$c visitor x in"; - if ($c) { + { say "and fold__$t__$c : type qstate . qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun { $c ?? 'visitor x' !! '_visitor ()' } state ->"; + # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; + if ($c eq '') { + # nothing to do, this constructor has no arguments. + } elsif ($c) { say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c visitor x state in"; } else { - say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold_$c visitor x state in"; + say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold__$c visitor x state in"; } say " state"; - # say " visitor.$t_$c x (fun () -> whole_adt_info, info_$t, info_$t_$c) state continue_fold"; + # say " visitor.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } } @@ -340,28 +351,30 @@ for $adts.list -> $t say " match v with"; if ($t eq $variant) { for $t.list -> $c - { say " | $c v -> let (v, state) = continue.$t_$c v state in ($c v, state)"; } + { given $c { + when '' { say " | $c -> let ((), state) = continue.$t__$c () state in ($c, state)"; } + default { say " | $c v -> let (v, state) = continue.$t__$c v state in ($c v, state)"; } } } } elsif ($t eq $record) { print ' { '; for $t.list -> $f { print "$f; "; } say "} ->"; for $t.list -> $f - { say " let ($f, state) = continue.$t_$f $f state in"; } + { say " let ($f, state) = continue.$t__$f $f state in"; } print ' ({ '; for $t.list -> $f { print "$f; "; } say '}, state)'; } else { - print " v -> fold_map_$t v state ( "; - print ( "continue.$t_$_" for $t.list ).join(", "); + print " v -> fold_map__$t v state ( "; + print ( "continue.$t__$_" for $t.list ).join(", "); say " )"; } say " );"; - say " $t_pre_state = (fun v (*_info*) state -> ignore v; state) ;"; - say " $t_post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;"; + say " $t__pre_state = (fun v (*_info*) state -> ignore v; state) ;"; + say " $t__post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;"; for $t.list -> $c - { print " $t_$c = (fun v (*_info*) state continue -> "; + { print " $t__$c = (fun v (*_info*) state continue -> "; if ($c) { print "ignore continue; (v, state)"; } else { diff --git a/src/test/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml index 0e3855bb8..b0a666dd6 100644 --- a/src/test/adt_generator/amodule_utils.ml +++ b/src/test/adt_generator/amodule_utils.ml @@ -1,10 +1,10 @@ -let fold_map_list v state continue = +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 = +let fold_map__option v state continue = match v with Some x -> continue x state | None -> None diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index c62c38e0f..8774e1200 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -8,15 +8,12 @@ let () = 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) + let (a1__' , state') = continue_fold.ta1 the_a.a1 state in + let (a2__' , state'') = continue_fold.ta2 the_a.a2 state' in + ({ a1__' ; a2__' }, state'' + 1) } in let state = 0 in - let (_, state) = fold_map_root op some_root state in + let (_, state) = fold_map__root op some_root state in if state != 2 then failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) else @@ -24,9 +21,9 @@ let () = let () = 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 _the_a (*_info*) state -> state + 1 } in let state = 0 in - let (_, state) = fold_map_root op some_root state in + let (_, state) = fold_map__root op some_root state in if state != 2 then failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) else @@ -34,9 +31,9 @@ let () = let () = 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 _the_a _new_a (*_info*) state -> state + 1 } in let state = 0 in - let (_, state) = fold_map_root op some_root state in + let (_, state) = fold_map__root op some_root state in if state != 2 then failwith (Printf.sprintf "Test failed: expected folder to count 2 nodes, but it counted %d nodes" state) else @@ -75,7 +72,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 some_root nostate 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 () From 2991e48ce6178a31c227abc902b1fa086b3e17f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sat, 28 Mar 2020 00:45:25 +0100 Subject: [PATCH 09/15] Implemented folds for the collections (lists and maps) --- src/stages/4-ast_typed/types_utils.ml | 33 ++++++++++++++++++++------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index d7d9aa61c..e8f968b77 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -28,15 +28,32 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe type location = Location.t type inline = bool -let fold_map__constructor_map : 'a . 'a constructor_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a constructor_map * 'state = fun _ _ _ -> failwith "TODO fold_map__constructor_map" +let fold_map__constructor_map : type a new_a state . a constructor_map -> state -> (a -> state -> new_a * state) -> new_a constructor_map * state = + fun m state f -> + let aux k v (state , m) = let (new_v , state) = f v state in (state , CMap.add k new_v m) in + let (state , m) = CMap.fold aux m (state, CMap.empty) in + (m , state) -let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = fun _ _ _ -> failwith "TODO fold_map__label_map" +let fold_map__label_map : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = + fun m state f -> + let aux k v (state , m) = let (new_v , state) = f v state in (state , LMap.add k new_v m) in + let (state , m) = LMap.fold aux m (state, LMap.empty) in + (m , state) -let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = fun l state f -> - let aux (state, l) element = let (new_element, state) = f element state in (state, new_element::l) in - let (state, l) = List.fold_left aux (state, []) l in - (l, state) +let fold_map__list : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = + fun l state f -> + let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in + let (state , l) = List.fold_left aux (state , []) l in + (l , state) -let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" +let fold_map__location_wrap : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = + fun { wrap_content ; location } state f -> + let (state , wrap_content) = f wrap_content state in + ({ wrap_content ; location }, state) -let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = fun _ _ _ -> failwith "TODO fold_map__location_wrap" +let fold_map__list_ne : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = + fun (first , l) state f -> + let (new_first , state) = f first state in + let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in + let (state , l) = List.fold_left aux (state , []) l in + ((new_first , l), state) From 253da1e9f50bb1a3497b5bd3e39f6a10233ec6ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sat, 28 Mar 2020 22:28:28 +0100 Subject: [PATCH 10/15] Break down the large fold_config structure into smaller structures --- src/stages/adt_generator/generator.raku | 66 +++++++++++++++---------- src/test/adt_generator/use_a_fold.ml | 13 ++--- 2 files changed, 47 insertions(+), 32 deletions(-) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 6430e0773..193cf291d 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -172,25 +172,35 @@ for $adts.kv -> $index, $t { } say ""; -say "type 'state continue_fold_map ="; -say ' {'; for $adts.list -> $t { - say " $t : $t -> 'state -> ($t * 'state) ;"; + say "type 'state continue_fold_map__$t = \{"; + say " node__$t : $t -> 'state -> ($t * 'state) ;"; for $t.list -> $c { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } + say ' }'; +} + +say "type 'state continue_fold_map = \{"; +for $adts.list -> $t { + say " $t : 'state continue_fold_map__$t ;"; } say ' }'; say ""; +for $adts.list -> $t +{ say "type 'state fold_map_config__$t = \{"; + say " node__$t : $t -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t * 'state) ;"; + say " node__$t__pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + say " node__$t__post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; + for $t.list -> $c + { say " $t__$c : {$c || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c || 'unit'} * 'state) ;"; + } + say '}' } + say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t -{ say " $t : $t -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t * 'state) ;"; - say " $t__pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; - say " $t__post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; - for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c || 'unit'} * 'state) ;"; - } } +{ say " $t : 'state fold_map_config__$t;" } say ' }'; say ""; @@ -295,9 +305,11 @@ say '(* Curries the "visitor" argument to the folds (non-customizable traversal say "and mk_continue_fold_map : type qstate . qstate fold_map_config -> qstate continue_fold_map = fun visitor ->"; say ' {'; for $adts.list -> $t -{ say " $t = fold_map__$t visitor ;"; +{ say " $t = \{"; + say " node__$t = fold_map__$t visitor ;"; for $t.list -> $c - { say " $t__$c = fold_map__$t__$c visitor ;"; } } + { say " $t__$c = fold_map__$t__$c visitor ;"; } + say ' };' } say ' }'; say ""; @@ -306,15 +318,15 @@ say ""; for $adts.list -> $t { say "and fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * 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__pre_state x (*(fun () -> whole_adt_info, info__$t)*) state in"; - say " let (new_x, state) = visitor.$t x (*(fun () -> whole_adt_info, info__$t)*) state continue_fold_map in"; - say " let state = visitor.$t__post_state x new_x (*(fun () -> whole_adt_info, info__$t)*) state in"; + say " let state = visitor.$t.node__$t__pre_state x (*(fun () -> whole_adt_info, info__$t)*) state in"; + say " let (new_x, state) = visitor.$t.node__$t x (*(fun () -> whole_adt_info, info__$t)*) state continue_fold_map in"; + say " let state = visitor.$t.node__$t__post_state x new_x (*(fun () -> whole_adt_info, info__$t)*) state in"; say " (new_x, state)"; say ""; for $t.list -> $c { say "and fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state ->"; say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in"; - say " visitor.$t__$c x (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) state continue_fold_map"; + say " visitor.$t.$t__$c x (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) state continue_fold_map"; say ""; } } @@ -327,7 +339,7 @@ for $adts.list -> $t say " adt = whole_adt_info () ;"; say " node_instance = continue_info__$t visitor x"; say ' } in'; - # say " let (new_x, state) = visitor.$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; + # say " let (new_x, state) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; say " visitor.generic node_instance_info state"; say ""; for $t.list -> $c @@ -341,44 +353,46 @@ for $adts.list -> $t say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) fold__$c visitor x state in"; } say " state"; - # say " visitor.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; + # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } } say "let no_op : 'a fold_map_config = \{"; for $adts.list -> $t -{ say " $t = (fun v (*_info*) state continue ->"; +{ say " $t = \{"; + say " node__$t = (fun v (*_info*) state continue ->"; say " match v with"; if ($t eq $variant) { for $t.list -> $c { given $c { - when '' { say " | $c -> let ((), state) = continue.$t__$c () state in ($c, state)"; } - default { say " | $c v -> let (v, state) = continue.$t__$c v state in ($c v, state)"; } } } + when '' { say " | $c -> let ((), state) = continue.$t.$t__$c () state in ($c, state)"; } + default { say " | $c v -> let (v, state) = continue.$t.$t__$c v state in ($c v, state)"; } } } } elsif ($t eq $record) { print ' { '; for $t.list -> $f { print "$f; "; } say "} ->"; for $t.list -> $f - { say " let ($f, state) = continue.$t__$f $f state in"; } + { say " let ($f, state) = continue.$t.$t__$f $f state in"; } print ' ({ '; for $t.list -> $f { print "$f; "; } say '}, state)'; } else { print " v -> fold_map__$t v state ( "; - print ( "continue.$t__$_" for $t.list ).join(", "); + print ( "continue.$t.$t__$_" for $t.list ).join(", "); say " )"; } say " );"; - say " $t__pre_state = (fun v (*_info*) state -> ignore v; state) ;"; - say " $t__post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;"; + say " node__$t__pre_state = (fun v (*_info*) state -> ignore v; state) ;"; + say " node__$t__post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;"; for $t.list -> $c { print " $t__$c = (fun v (*_info*) state continue -> "; if ($c) { print "ignore continue; (v, state)"; } else { - print "continue.$c v state"; + print "continue.$c.node__$c v state"; } - say ") ;"; } } + say ") ;"; } + say ' };' } say '}'; diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 8774e1200..5591d87cf 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -7,10 +7,11 @@ let () = 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__' ; a2__' }, state'' + 1) + a = { no_op.a with + node__a = fun the_a (*_info*) state continue_fold -> + let (a1__' , state') = continue_fold.ta1.node__ta1 the_a.a1 state in + let (a2__' , state'') = continue_fold.ta2.node__ta2 the_a.a2 state' in + ({ a1__' ; a2__' }, state'' + 1) } } in let state = 0 in let (_, state) = fold_map__root op some_root state in @@ -21,7 +22,7 @@ let () = let () = 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 = { no_op.a with node__a__pre_state = fun _the_a (*_info*) state -> state + 1 } } in let state = 0 in let (_, state) = fold_map__root op some_root state in if state != 2 then @@ -31,7 +32,7 @@ let () = let () = 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 = { no_op.a with node__a__post_state = fun _the_a _new_a (*_info*) state -> state + 1 } } in let state = 0 in let (_, state) = fold_map__root op some_root state in if state != 2 then From 642c947ee44989504e3d54d4bf11c1f25b2f0a1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 31 Mar 2020 21:58:48 +0200 Subject: [PATCH 11/15] [WIP, does not build] adt_generator move polymorphism into the fields, start getting rid of the large let rec --- src/stages/adt_generator/generator.raku | 165 +++++++++++++++--------- 1 file changed, 102 insertions(+), 63 deletions(-) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 193cf291d..7a0dcbd9b 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -173,34 +173,34 @@ for $adts.kv -> $index, $t { say ""; for $adts.list -> $t { - say "type 'state continue_fold_map__$t = \{"; - say " node__$t : $t -> 'state -> ($t * 'state) ;"; + say "type continue_fold_map__$t = \{"; + say " node__$t : 'state . $t -> 'state -> ($t * 'state) ;"; for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } + { say " $t__$c : 'state . {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } say ' }'; } -say "type 'state continue_fold_map = \{"; +say "type continue_fold_map = \{"; for $adts.list -> $t { - say " $t : 'state continue_fold_map__$t ;"; + say " $t : continue_fold_map__$t ;"; } say ' }'; say ""; for $adts.list -> $t -{ say "type 'state fold_map_config__$t = \{"; - say " node__$t : $t -> (*Adt_info.node_instance_info ->*) 'state -> ('state continue_fold_map) -> ($t * 'state) ;"; - say " node__$t__pre_state : $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; - say " node__$t__post_state : $t -> $t -> (*Adt_info.node_instance_info ->*) 'state -> 'state ;"; +{ say "type fold_map_config__$t = \{"; + say " node__$t : 'state . $t -> 'state -> continue_fold_map -> ($t * 'state) ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : 'state . $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : 'state . $t -> $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> (*Adt_info.ctor_or_field_instance_info ->*) 'state -> ('state continue_fold_map) -> ({$c || 'unit'} * 'state) ;"; + { say " $t__$c : 'state . {$c || 'unit'} -> 'state -> continue_fold_map -> ({$c || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } say '}' } -say "type 'state fold_map_config ="; +say "type fold_map_config ="; say ' {'; for $adts.list -> $t -{ say " $t : 'state fold_map_config__$t;" } +{ say " $t : fold_map_config__$t;" } say ' }'; say ""; @@ -222,30 +222,33 @@ for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''} for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).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 ""; +say 'type blahblah = {'; for $adts.list -> $t -{ print "info__$t ; "; } -say "]"; +{ say " fold__$t : 'state . blahblah -> 'state fold_config -> $t -> 'state -> 'state;"; + for $t.list -> $c + { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> { $c || 'unit' } -> 'state -> 'state;"; } } +say '}'; # generic programming info about the nodes and fields say ""; for $adts.list -> $t { for $t.list -> $c { say "(* info for field or ctor $t.$c *)"; - say "and info__$t__$c : Adt_info.ctor_or_field = \{"; + say "let info__$t__$c : Adt_info.ctor_or_field = \{"; say " name = \"$c\";"; say " is_builtin = {$c ?? 'true' !! 'false'};"; say " type_ = \"$c\";"; say '}'; say ""; - say "and continue_info__$t__$c : type qstate . qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun visitor x -> \{"; + say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say " cf = info__$t__$c;"; - say " cf_continue = fun state -> fold__$t__$c visitor x state;"; + say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor x state;"; say '}'; say ""; } say "(* info for node $t *)"; - say "and info__$t : Adt_info.node = \{"; + say "let info__$t : Adt_info.node = \{"; my $kind = do given $t { when $record { "Record" } when $variant { "Variant" } @@ -259,21 +262,21 @@ for $adts.list -> $t say '}'; say ""; # TODO: factor out some of the common bits here. - say "and continue_info__$t : type qstate . qstate fold_config -> $t -> qstate Adt_info.instance = fun visitor x ->"; + say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->"; say '{'; say " instance_declaration_name = \"$t\";"; do given $t { when $record { say ' instance_kind = RecordInstance {'; print " fields = [ "; - for $t.list -> $c { print "continue_info__$t__$c visitor x.$c ; "; } + for $t.list -> $c { print "continue_info__$t__$c blahblah visitor x.$c ; "; } say " ];"; say '};'; } when $variant { say ' instance_kind = VariantInstance {'; say " constructor = (match x with"; - for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c visitor { $c ?? 'v' !! '()' }"; } + for $t.list -> $c { say " | $c { $c ?? 'v ' !! '' }-> continue_info__$t__$c blahblah visitor { $c ?? 'v' !! '()' }"; } say " );"; print " variant = [ "; for $t.list -> $c { print "info__$t__$c ; "; } @@ -290,7 +293,7 @@ for $adts.list -> $t say "];"; print " poly_continue = (fun state -> visitor.$_ visitor x ("; print $t - .map(-> $c { "(fun state x -> (continue_info__$t__$c visitor x).cf_continue state)" }) + .map(-> $c { "(fun state x -> (continue_info__$t__$c blahblah visitor x).cf_continue state)" }) .join(", "); say ") state);"; say '};'; @@ -299,68 +302,104 @@ for $adts.list -> $t 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 = \{"; - say " node__$t = fold_map__$t visitor ;"; - for $t.list -> $c - { say " $t__$c = fold_map__$t__$c visitor ;"; } - say ' };' } -say ' }'; -say ""; - -# fold_map functions -say ""; -for $adts.list -> $t -{ say "and fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * 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.node__$t__pre_state x (*(fun () -> whole_adt_info, info__$t)*) state in"; - say " let (new_x, state) = visitor.$t.node__$t x (*(fun () -> whole_adt_info, info__$t)*) state continue_fold_map in"; - say " let state = visitor.$t.node__$t__post_state x new_x (*(fun () -> whole_adt_info, info__$t)*) state in"; - say " (new_x, state)"; - say ""; - for $t.list -> $c - { say "and fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state ->"; - say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map visitor in"; - say " visitor.$t.$t__$c x (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) state continue_fold_map"; - say ""; } } - +{ print "info__$t ; "; } +say "]"; # fold functions say ""; for $adts.list -> $t -{ say "and fold__$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state ->"; +{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate -> qstate = fun blahblah visitor x state ->"; # 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 visitor x"; + say " node_instance = continue_info__$t blahblah visitor x"; say ' } in'; # say " let (new_x, state) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; say " visitor.generic node_instance_info state"; say ""; for $t.list -> $c - { say "and fold__$t__$c : type qstate . qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun { $c ?? 'visitor x' !! '_visitor ()' } state ->"; + { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun blahblah { $c ?? 'visitor x' !! '_visitor ()' } state ->"; # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; if ($c eq '') { # nothing to do, this constructor has no arguments. + say " state"; } elsif ($c) { - say " let state = (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) visitor.$c visitor x state in"; + say " ignore blahblah; visitor.$c visitor x state"; # (*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 visitor x state in"; + say " blahblah.fold__$c blahblah visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } - say " state"; # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } } -say "let no_op : 'a fold_map_config = \{"; +say ""; +say 'let blahblah : blahblah = {'; +for $adts.list -> $t +{ say " fold__$t;"; + for $t.list -> $c + { say " fold__$t__$c;" } } +say '}'; + +say ""; +for $adts.list -> $t +{ say "let fold__$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state -> fold__$t blahblah visitor x state"; + for $t.list -> $c + { say "let fold__$t__$c : type qstate . qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun visitor x state -> fold__$t__$c blahblah visitor x state" } } + + +say ""; +say 'type mk_continue_fold_map = {'; +say " fn : mk_continue_fold_map -> fold_map_config -> continue_fold_map"; +say '}'; + + +# fold_map functions +say ""; +for $adts.list -> $t +{ say "let _fold_map__$t : type qstate . mk_continue_fold_map -> fold_map_config -> $t -> qstate -> ($t * qstate) = fun mk_continue_fold_map visitor x state ->"; + say " let continue_fold_map : continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; + say " let state = visitor.$t.node__$t__pre_state x state in"; # (*(fun () -> whole_adt_info, info__$t)*) + say " let (new_x, state) = visitor.$t.node__$t x state continue_fold_map in"; # (*(fun () -> whole_adt_info, info__$t)*) + say " let state = visitor.$t.node__$t__post_state x new_x state in"; # (*(fun () -> whole_adt_info, info__$t)*) + say " (new_x, state)"; + say ""; + for $t.list -> $c + { say "let _fold_map__$t__$c : type qstate . mk_continue_fold_map -> fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; + say " let continue_fold_map : continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; + say " visitor.$t.$t__$c x state continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + say ""; } } + +# make the "continue" object +say ""; +say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; +say "let mk_continue_fold_map : mk_continue_fold_map = \{ fn = fun self visitor ->"; +say ' {'; +for $adts.list -> $t +{ say " $t = \{"; + say " node__$t = (fun x state -> _fold_map__$t self visitor x state) ;"; + for $t.list -> $c + { say " $t__$c = (fun x state -> _fold_map__$t__$c self visitor x state) ;"; } + say ' };' } +say ' }'; +say '}'; +say ""; + +# fold_map functions : tying the knot +say ""; +for $adts.list -> $t +{ say "let fold_map__$t : type qstate . fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state -> _fold_map__$t mk_continue_fold_map visitor x state"; + for $t.list -> $c + { say "let fold_map__$t__$c : type qstate . fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t__$c mk_continue_fold_map visitor x state"; } } + + +say "let no_op : fold_map_config = \{"; for $adts.list -> $t { say " $t = \{"; - say " node__$t = (fun v (*_info*) state continue ->"; + say " node__$t = (fun v state continue ->"; # (*_info*) say " match v with"; if ($t eq $variant) { for $t.list -> $c @@ -384,10 +423,10 @@ for $adts.list -> $t say " )"; } say " );"; - say " node__$t__pre_state = (fun v (*_info*) state -> ignore v; state) ;"; - say " node__$t__post_state = (fun v new_v (*_info*) state -> ignore (v, new_v); state) ;"; + say " node__$t__pre_state = (fun v state -> ignore v; state) ;"; # (*_info*) + say " node__$t__post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; # (*_info*) for $t.list -> $c - { print " $t__$c = (fun v (*_info*) state continue -> "; + { print " $t__$c = (fun v state continue -> "; # (*_info*) if ($c) { print "ignore continue; (v, state)"; } else { From 1e1728e5dd03b303914b8a8cea64b1704c19082b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 31 Mar 2020 23:26:01 +0200 Subject: [PATCH 12/15] [WIP, does not build] Remove some polymorphism : customized visitors must be specific to their accumulator type --- src/stages/adt_generator/generator.raku | 44 ++++++++++++------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 7a0dcbd9b..57c27ee8c 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -173,34 +173,34 @@ for $adts.kv -> $index, $t { say ""; for $adts.list -> $t { - say "type continue_fold_map__$t = \{"; - say " node__$t : 'state . $t -> 'state -> ($t * 'state) ;"; + say "type 'state continue_fold_map__$t = \{"; + say " node__$t : $t -> 'state -> ($t * 'state) ;"; for $t.list -> $c - { say " $t__$c : 'state . {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } + { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } say ' }'; } -say "type continue_fold_map = \{"; +say "type 'state continue_fold_map = \{"; for $adts.list -> $t { - say " $t : continue_fold_map__$t ;"; + say " $t : 'state continue_fold_map__$t ;"; } say ' }'; say ""; for $adts.list -> $t -{ say "type fold_map_config__$t = \{"; - say " node__$t : 'state . $t -> 'state -> continue_fold_map -> ($t * 'state) ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__pre_state : 'state . $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__post_state : 'state . $t -> $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) +{ say "type 'state fold_map_config__$t = \{"; + say " node__$t : $t -> 'state -> 'state continue_fold_map -> ($t * 'state) ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : $t -> $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) for $t.list -> $c - { say " $t__$c : 'state . {$c || 'unit'} -> 'state -> continue_fold_map -> ({$c || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) + { say " $t__$c : {$c || 'unit'} -> 'state -> 'state continue_fold_map -> ({$c || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } say '}' } -say "type fold_map_config ="; +say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t -{ say " $t : fold_map_config__$t;" } +{ say " $t : 'state fold_map_config__$t;" } say ' }'; say ""; @@ -352,31 +352,31 @@ for $adts.list -> $t say ""; -say 'type mk_continue_fold_map = {'; -say " fn : mk_continue_fold_map -> fold_map_config -> continue_fold_map"; +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 : type qstate . mk_continue_fold_map -> fold_map_config -> $t -> qstate -> ($t * qstate) = fun mk_continue_fold_map visitor x state ->"; - say " let continue_fold_map : continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; +{ say "let _fold_map__$t : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun mk_continue_fold_map visitor x state ->"; + say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; say " let state = visitor.$t.node__$t__pre_state x state in"; # (*(fun () -> whole_adt_info, info__$t)*) say " let (new_x, state) = visitor.$t.node__$t x state continue_fold_map in"; # (*(fun () -> whole_adt_info, info__$t)*) say " let state = visitor.$t.node__$t__post_state x new_x state in"; # (*(fun () -> whole_adt_info, info__$t)*) say " (new_x, state)"; say ""; for $t.list -> $c - { say "let _fold_map__$t__$c : type qstate . mk_continue_fold_map -> fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; - say " let continue_fold_map : continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; + { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; + say " let continue_fold_map : qstate continue_fold_map = mk_continue_fold_map.fn mk_continue_fold_map visitor in"; say " visitor.$t.$t__$c x state continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) say ""; } } # make the "continue" object say ""; say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; -say "let mk_continue_fold_map : mk_continue_fold_map = \{ fn = fun self visitor ->"; +say "let mk_continue_fold_map : 'stateX . 'stateX mk_continue_fold_map = \{ fn = fun self visitor ->"; say ' {'; for $adts.list -> $t { say " $t = \{"; @@ -391,12 +391,12 @@ say ""; # fold_map functions : tying the knot say ""; for $adts.list -> $t -{ say "let fold_map__$t : type qstate . fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state -> _fold_map__$t mk_continue_fold_map visitor x state"; +{ say "let fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state -> _fold_map__$t mk_continue_fold_map visitor x state"; for $t.list -> $c - { say "let fold_map__$t__$c : type qstate . fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t__$c mk_continue_fold_map visitor x state"; } } + { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t__$c mk_continue_fold_map visitor x state"; } } -say "let no_op : fold_map_config = \{"; +say "let no_op : 'state . 'state fold_map_config = \{"; for $adts.list -> $t { say " $t = \{"; say " node__$t = (fun v state continue ->"; # (*_info*) From ded76b41d6d703b802ddc43f74f659f59603ad86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Wed, 1 Apr 2020 16:14:43 +0200 Subject: [PATCH 13/15] Adt generator: split structure into smaller structures; use the monad; reordered function, state and value arguments to match the order of List.fold_left. --- src/stages/4-ast_typed/PP_generic.ml | 42 ++++++++ src/stages/4-ast_typed/fold.ml | 1 + src/stages/4-ast_typed/types_utils.ml | 62 +++++++----- src/stages/adt_generator/generator.raku | 127 ++++++++++++++---------- src/test/adt_generator/amodule_utils.ml | 20 ++-- src/test/adt_generator/dune | 5 +- src/test/adt_generator/use_a_fold.ml | 56 +++++++---- 7 files changed, 205 insertions(+), 108 deletions(-) create mode 100644 src/stages/4-ast_typed/PP_generic.ml create mode 100644 src/stages/4-ast_typed/fold.ml diff --git a/src/stages/4-ast_typed/PP_generic.ml b/src/stages/4-ast_typed/PP_generic.ml new file mode 100644 index 000000000..22ad1a2a1 --- /dev/null +++ b/src/stages/4-ast_typed/PP_generic.ml @@ -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 diff --git a/src/stages/4-ast_typed/fold.ml b/src/stages/4-ast_typed/fold.ml new file mode 100644 index 000000000..271974820 --- /dev/null +++ b/src/stages/4-ast_typed/fold.ml @@ -0,0 +1 @@ +include Generated_fold diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index e8f968b77..24835256c 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -1,4 +1,5 @@ module S = Ast_core +open Simple_utils.Trace (* include Stage_common.Types *) (* type expression_ @@ -28,32 +29,43 @@ type packed_internal_operation = Memory_proto_alpha.Protocol.Alpha_context.packe type location = Location.t type inline = bool -let fold_map__constructor_map : type a new_a state . a constructor_map -> state -> (a -> state -> new_a * state) -> new_a constructor_map * state = - fun m state f -> - let aux k v (state , m) = let (new_v , state) = f v state in (state , CMap.add k new_v m) in - let (state , m) = CMap.fold aux m (state, CMap.empty) in - (m , state) +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 : 'a . 'a label_map -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a label_map * 'state = - fun m state f -> - let aux k v (state , m) = let (new_v , state) = f v state in (state , LMap.add k new_v m) in - let (state , m) = LMap.fold aux m (state, LMap.empty) in - (m , state) +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 : 'a . 'a list -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list * 'state = - fun l state f -> - let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in - let (state , l) = List.fold_left aux (state , []) l in - (l , state) +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 : 'a . 'a location_wrap -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a location_wrap * 'state = - fun { wrap_content ; location } state f -> - let (state , wrap_content) = f wrap_content state in - ({ wrap_content ; location }, state) +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 : 'a . 'a list_ne -> 'state -> ('a -> 'state -> 'new_a * 'state) -> 'new_a list_ne * 'state = - fun (first , l) state f -> - let (new_first , state) = f first state in - let aux (state , l) element = let (new_element , state) = f element state in (state , new_element :: l) in - let (state , l) = List.fold_left aux (state , []) l in - ((new_first , l), state) +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)) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index 57c27ee8c..adfd6b80d 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -143,9 +143,17 @@ say ""; 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({$_ ne $record && $_ ne $variant}).map({$_}).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"; @@ -174,9 +182,9 @@ for $adts.kv -> $index, $t { say ""; for $adts.list -> $t { say "type 'state continue_fold_map__$t = \{"; - say " node__$t : $t -> 'state -> ($t * 'state) ;"; + say " node__$t : 'state -> $t -> ('state * $t) monad ;"; for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> 'state -> ({$c || 'unit'} * 'state) ;" } + { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'}) monad ;" } say ' }'; } @@ -189,11 +197,11 @@ say ' }'; say ""; for $adts.list -> $t { say "type 'state fold_map_config__$t = \{"; - say " node__$t : $t -> 'state -> 'state continue_fold_map -> ($t * 'state) ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__pre_state : $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) - say " node__$t__post_state : $t -> $t -> 'state -> 'state ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t : 'state -> $t -> 'state continue_fold_map -> ('state * $t) monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__pre_state : 'state -> $t -> 'state monad ;"; # (*Adt_info.node_instance_info ->*) + say " node__$t__post_state : 'state -> $t -> $t -> 'state monad ;"; # (*Adt_info.node_instance_info ->*) for $t.list -> $c - { say " $t__$c : {$c || 'unit'} -> 'state -> 'state continue_fold_map -> ({$c || 'unit'} * 'state) ;"; # (*Adt_info.ctor_or_field_instance_info ->*) + { say " $t__$c : 'state -> {$c || 'unit'} -> 'state continue_fold_map -> ('state * {$c || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } say '}' } @@ -216,19 +224,21 @@ say "type 'state generic_continue_fold = ('state generic_continue_fold_node) Str say ""; say "type 'state fold_config ="; say ' {'; -say " generic : 'state Adt_info.node_instance_info -> 'state -> 'state;"; +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({ $_ })[*;*].grep({$_ && $_ ne ''}).map({$_}).unique -> $builtin -{ say " $builtin : 'state fold_config -> $builtin -> 'state -> 'state;"; } -for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $builtin -{ say " $builtin : 'a . 'state fold_config -> 'a $builtin -> ('state -> 'a -> 'state) -> 'state -> 'state;"; } +{ say " $builtin : 'state fold_config -> 'state -> $builtin -> 'state;"; } +# look for built-in polymorphic types +for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly +{ say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } say ' }'; say ""; say 'type blahblah = {'; for $adts.list -> $t -{ say " fold__$t : 'state . blahblah -> 'state fold_config -> $t -> 'state -> 'state;"; +{ say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; for $t.list -> $c - { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> { $c || 'unit' } -> 'state -> 'state;"; } } + { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } say '}'; # generic programming info about the nodes and fields @@ -244,7 +254,7 @@ for $adts.list -> $t say ""; say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say " cf = info__$t__$c;"; - say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor x state;"; + say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor state x;"; say '}'; say ""; } say "(* info for node $t *)"; @@ -291,11 +301,11 @@ for $adts.list -> $t # polymorphic types so it happens to work but should be fixed. for $t.list -> $c { print "\"$c\""; } say "];"; - print " poly_continue = (fun state -> visitor.$_ visitor x ("; + print " poly_continue = (fun state -> visitor.$_ visitor ("; print $t .map(-> $c { "(fun state x -> (continue_info__$t__$c blahblah visitor x).cf_continue state)" }) .join(", "); - say ") state);"; + say ") state x);"; say '};'; } }; @@ -312,25 +322,25 @@ say "]"; # fold functions say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate -> qstate = fun blahblah visitor x state ->"; +{ say "let fold__$t : type qstate . blahblah -> qstate fold_config -> qstate -> $t -> 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 blahblah visitor x"; say ' } in'; - # say " let (new_x, state) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic node_instance_info state"; + # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; + say " visitor.generic state node_instance_info"; say ""; for $t.list -> $c - { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun blahblah { $c ?? 'visitor x' !! '_visitor ()' } state ->"; + { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; if ($c eq '') { # nothing to do, this constructor has no arguments. - say " state"; + say " ignore blahblah; state"; } elsif ($c) { - say " ignore blahblah; visitor.$c visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " ignore blahblah; visitor.$c visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } else { - say " blahblah.fold__$c blahblah visitor x state"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " blahblah.fold__$c blahblah visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } @@ -344,11 +354,12 @@ for $adts.list -> $t { say " fold__$t__$c;" } } say '}'; +# Tying the knot say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> $t -> qstate -> qstate = fun visitor x state -> fold__$t blahblah visitor x state"; +{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x"; for $t.list -> $c - { say "let fold__$t__$c : type qstate . qstate fold_config -> { $c || 'unit' } -> qstate -> qstate = fun visitor x state -> fold__$t__$c blahblah visitor x state" } } + { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x" } } say ""; @@ -360,29 +371,29 @@ say '}'; # fold_map functions say ""; for $adts.list -> $t -{ say "let _fold_map__$t : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun mk_continue_fold_map visitor x state ->"; +{ say "let _fold_map__$t : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> $t -> (qstate * $t) 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 " let state = visitor.$t.node__$t__pre_state x state in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " let (new_x, state) = visitor.$t.node__$t x state continue_fold_map in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " let state = visitor.$t.node__$t__post_state x new_x state in"; # (*(fun () -> whole_adt_info, info__$t)*) - say " (new_x, state)"; + say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) + say " return (state, new_x)"; say ""; for $t.list -> $c - { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun mk_continue_fold_map visitor x state ->"; + { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || '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.$t__$c x state continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + say " visitor.$t.$t__$c state x continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) say ""; } } # make the "continue" object say ""; say '(* Curries the "visitor" argument to the folds (non-customizable traversal functions). *)'; -say "let mk_continue_fold_map : 'stateX . 'stateX mk_continue_fold_map = \{ fn = fun self visitor ->"; +say "let mk_continue_fold_map : 'state . 'state mk_continue_fold_map = \{ fn = fun self visitor ->"; say ' {'; for $adts.list -> $t { say " $t = \{"; - say " node__$t = (fun x state -> _fold_map__$t self visitor x state) ;"; + say " node__$t = (fun state x -> _fold_map__$t self visitor state x) ;"; for $t.list -> $c - { say " $t__$c = (fun x state -> _fold_map__$t__$c self visitor x state) ;"; } + { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } say ' };' } say ' }'; say '}'; @@ -391,47 +402,57 @@ say ""; # fold_map functions : tying the knot say ""; for $adts.list -> $t -{ say "let fold_map__$t : type qstate . qstate fold_map_config -> $t -> qstate -> ($t * qstate) = fun visitor x state -> _fold_map__$t mk_continue_fold_map visitor x state"; +{ say "let fold_map__$t : type qstate . qstate fold_map_config -> qstate -> $t -> (qstate * $t) monad ="; + say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x"; for $t.list -> $c - { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> { $c || 'unit' } -> qstate -> ({ $c || 'unit' } * qstate) = fun visitor x state -> _fold_map__$t__$c mk_continue_fold_map visitor x state"; } } + { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }) monad ="; + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x"; } } -say "let no_op : 'state . 'state fold_map_config = \{"; for $adts.list -> $t -{ say " $t = \{"; - say " node__$t = (fun v state continue ->"; # (*_info*) +{ + say "let no_op_node__$t : type state . state -> $t -> state continue_fold_map -> (state * $t) monad ="; + say " fun state v continue ->"; # (*_info*) say " match v with"; if ($t eq $variant) { for $t.list -> $c { given $c { - when '' { say " | $c -> let ((), state) = continue.$t.$t__$c () state in ($c, state)"; } - default { say " | $c v -> let (v, state) = continue.$t.$t__$c v state in ($c v, state)"; } } } + when '' { say " | $c -> continue.$t.$t__$c state () >>? fun (state , ()) -> return (state , $c)"; } + default { say " | $c v -> continue.$t.$t__$c state v >>? fun (state , v) -> return (state , $c v)"; } } } } elsif ($t eq $record) { print ' { '; for $t.list -> $f { print "$f; "; } say "} ->"; for $t.list -> $f - { say " let ($f, state) = continue.$t.$t__$f $f state in"; } - print ' ({ '; + { say " continue.$t.$t__$f state $f >>? fun (state , $f) ->"; } + print ' return (state , ({ '; for $t.list -> $f { print "$f; "; } - say '}, state)'; + say "\} : $t))"; } else { - print " v -> fold_map__$t v state ( "; + print " v -> fold_map__$t ( "; print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " )"; + say " ) state v"; } - say " );"; - say " node__$t__pre_state = (fun v state -> ignore v; state) ;"; # (*_info*) - say " node__$t__post_state = (fun v new_v state -> ignore (v, new_v); state) ;"; # (*_info*) +} + +for $adts.list -> $t +{ say "let no_op__$t : type state . state fold_map_config__$t = \{"; + say " node__$t = no_op_node__$t;"; + say " node__$t__pre_state = (fun state v -> ignore v; return state) ;"; # (*_info*) + say " node__$t__post_state = (fun state v new_v -> ignore (v, new_v); return state) ;"; # (*_info*) for $t.list -> $c - { print " $t__$c = (fun v state continue -> "; # (*_info*) + { print " $t__$c = (fun state v continue -> "; # (*_info*) if ($c) { - print "ignore continue; (v, state)"; + print "ignore continue; return (state , v)"; } else { - print "continue.$c.node__$c v state"; + print "continue.$c.node__$c state v"; } say ") ;"; } - say ' };' } + say ' }' } + +say "let no_op : type state . state fold_map_config = \{"; +for $adts.list -> $t +{ say " $t = no_op__$t;" } say '}'; diff --git a/src/test/adt_generator/amodule_utils.ml b/src/test/adt_generator/amodule_utils.ml index b0a666dd6..6befe8167 100644 --- a/src/test/adt_generator/amodule_utils.ml +++ b/src/test/adt_generator/amodule_utils.ml @@ -1,10 +1,14 @@ -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 +open Simple_utils.Trace -let fold_map__option v state continue = +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 x state - | None -> None + Some x -> continue state x + | None -> ok None diff --git a/src/test/adt_generator/dune b/src/test/adt_generator/dune index 679b3a0fd..63fabe8ed 100644 --- a/src/test/adt_generator/dune +++ b/src/test/adt_generator/dune @@ -8,7 +8,10 @@ (executable (name test_adt_generator) (public_name ligo.test_adt_generator) - (libraries adt_generator) + (libraries adt_generator simple-utils) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) ) (alias diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 5591d87cf..617c5914c 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -1,44 +1,58 @@ open Amodule open Fold +open Simple_utils.Trace + +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 = { no_op.a with - node__a = fun the_a (*_info*) state continue_fold -> - let (a1__' , state') = continue_fold.ta1.node__ta1 the_a.a1 state in - let (a2__' , state'') = continue_fold.ta2.node__ta2 the_a.a2 state' in - ({ a1__' ; a2__' }, state'' + 1) } + node__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 = { no_op.a with node__a__pre_state = fun _the_a (*_info*) state -> state + 1 } } in + let op = { no_op with a = { no_op.a with node__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 = { no_op.a with node__a__post_state = fun _the_a _new_a (*_info*) state -> state + 1 } } in + let op = { no_op with a = { no_op.a with node__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 *) @@ -50,7 +64,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 } -> @@ -62,10 +76,10 @@ let () = | 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 -> @@ -73,7 +87,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 () From b536d3f59147bdca704909460e509189e1e1d7ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 2 Apr 2020 19:14:43 +0200 Subject: [PATCH 14/15] Remove early Perl 5 and Python versions of the ADT generator --- src/stages/adt_generator/generator.pl | 212 -------------------------- src/stages/adt_generator/generator.py | 171 --------------------- 2 files changed, 383 deletions(-) delete mode 100644 src/stages/adt_generator/generator.pl delete mode 100644 src/stages/adt_generator/generator.py diff --git a/src/stages/adt_generator/generator.pl b/src/stages/adt_generator/generator.pl deleted file mode 100644 index c145a5b4b..000000000 --- a/src/stages/adt_generator/generator.pl +++ /dev/null @@ -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 "}"; diff --git a/src/stages/adt_generator/generator.py b/src/stages/adt_generator/generator.py deleted file mode 100644 index e4af0468a..000000000 --- a/src/stages/adt_generator/generator.py +++ /dev/null @@ -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("}") From e0011547140609a0f7a95b5ddb1d211d01846d71 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sun, 5 Apr 2020 20:17:55 +0200 Subject: [PATCH 15/15] with_xxx shorthands for fold configurations --- src/stages/adt_generator/generator.raku | 78 ++++++++++++++----------- src/test/adt_generator/use_a_fold.ml | 24 ++++---- 2 files changed, 57 insertions(+), 45 deletions(-) diff --git a/src/stages/adt_generator/generator.raku b/src/stages/adt_generator/generator.raku index adfd6b80d..f3938f900 100644 --- a/src/stages/adt_generator/generator.raku +++ b/src/stages/adt_generator/generator.raku @@ -143,16 +143,16 @@ say ""; 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 "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({$_ ne $record && $_ ne $variant}).map({$_}).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 "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 { @@ -165,6 +165,7 @@ for $adts.kv -> $index, $t { default { say " | $c of $c" } } } + say ""; } elsif ($t eq $record) { say ' {'; for $t.list -> $f @@ -178,6 +179,7 @@ for $adts.kv -> $index, $t { say ""; } } +say ";;"; say ""; for $adts.list -> $t { @@ -185,14 +187,14 @@ for $adts.list -> $t { say " node__$t : 'state -> $t -> ('state * $t) monad ;"; for $t.list -> $c { say " $t__$c : 'state -> {$c || 'unit'} -> ('state * {$c || 'unit'}) monad ;" } - say ' }'; + say ' };;'; } say "type 'state continue_fold_map = \{"; for $adts.list -> $t { say " $t : 'state continue_fold_map__$t ;"; } -say ' }'; +say ' };;'; say ""; for $adts.list -> $t @@ -203,24 +205,24 @@ for $adts.list -> $t for $t.list -> $c { say " $t__$c : 'state -> {$c || 'unit'} -> 'state continue_fold_map -> ('state * {$c || 'unit'}) monad ;"; # (*Adt_info.ctor_or_field_instance_info ->*) } - say '}' } + say '};;' } say "type 'state fold_map_config ="; say ' {'; for $adts.list -> $t { say " $t : 'state fold_map_config__$t;" } -say ' }'; +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 ' {'; @@ -231,7 +233,7 @@ for $adts.map({ $_ })[*;*].grep({$_ && $_ ne ''} # look for built-in polymorphic types for $adts.grep({$_ ne $record && $_ ne $variant}).map({$_}).unique -> $poly { say " $poly : 'a . 'state fold_config -> ('state -> 'a -> 'state) -> 'state -> 'a $poly -> 'state;"; } -say ' }'; +say ' };;'; say ""; say 'type blahblah = {'; @@ -239,7 +241,7 @@ for $adts.list -> $t { say " fold__$t : 'state . blahblah -> 'state fold_config -> 'state -> $t -> 'state;"; for $t.list -> $c { say " fold__$t__$c : 'state . blahblah -> 'state fold_config -> 'state -> { $c || 'unit' } -> 'state;"; } } -say '}'; +say '};;'; # generic programming info about the nodes and fields say ""; @@ -255,7 +257,7 @@ for $adts.list -> $t say "let continue_info__$t__$c : type qstate . blahblah -> qstate fold_config -> {$c || 'unit'} -> qstate Adt_info.ctor_or_field_instance = fun blahblah visitor x -> \{"; say " cf = info__$t__$c;"; say " cf_continue = fun state -> blahblah.fold__$t__$c blahblah visitor state x;"; - say '}'; + say '};;'; say ""; } say "(* info for node $t *)"; say "let info__$t : Adt_info.node = \{"; @@ -269,7 +271,7 @@ for $adts.list -> $t print " ctors_or_fields = [ "; for $t.list -> $c { print "info__$t__$c ; "; } say "];"; - say '}'; + say '};;'; say ""; # TODO: factor out some of the common bits here. say "let continue_info__$t : type qstate . blahblah -> qstate fold_config -> $t -> qstate Adt_info.instance = fun blahblah visitor x ->"; @@ -309,7 +311,7 @@ for $adts.list -> $t say '};'; } }; - say '}'; + say '};;'; say ""; } say ""; @@ -317,7 +319,7 @@ say "(* info for adt $moduleName *)"; print "let whole_adt_info : unit -> Adt_info.adt = fun () -> [ "; for $adts.list -> $t { print "info__$t ; "; } -say "]"; +say "];;"; # fold functions say ""; @@ -329,18 +331,18 @@ for $adts.list -> $t say " node_instance = continue_info__$t blahblah visitor x"; say ' } in'; # say " let (state, new_x) = visitor.$t.node__$t x (fun () -> whole_adt_info, info__$t) state continue_fold in"; - say " visitor.generic state node_instance_info"; + say " visitor.generic state node_instance_info;;"; say ""; for $t.list -> $c { say "let fold__$t__$c : type qstate . blahblah -> qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun blahblah { $c ?? 'visitor' !! '_visitor' } state { $c ?? 'x' !! '()' } ->"; # say " let ctor_or_field_instance_info : qstate Adt_info.ctor_or_field_instance_info = whole_adt_info (), info__$t, continue_info__$t__$c visitor x in"; if ($c eq '') { # nothing to do, this constructor has no arguments. - say " ignore blahblah; state"; + say " ignore blahblah; state;;"; } elsif ($c) { - say " ignore blahblah; visitor.$c visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " ignore blahblah; visitor.$c visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } else { - say " blahblah.fold__$c blahblah visitor state x"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) + say " blahblah.fold__$c blahblah visitor state x;;"; # (*visitor.generic_ctor_or_field ctor_or_field_instance_info*) } # say " visitor.$t.$t__$c x (fun () -> whole_adt_info, info__$t, info__$t__$c) state continue_fold"; say ""; } @@ -352,20 +354,20 @@ for $adts.list -> $t { say " fold__$t;"; for $t.list -> $c { say " fold__$t__$c;" } } -say '}'; +say '};;'; # Tying the knot say ""; for $adts.list -> $t -{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x"; +{ say "let fold__$t : type qstate . qstate fold_config -> qstate -> $t -> qstate = fun visitor state x -> fold__$t blahblah visitor state x;;"; for $t.list -> $c - { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c blahblah visitor state x" } } + { say "let fold__$t__$c : type qstate . qstate fold_config -> qstate -> { $c || 'unit' } -> qstate = fun visitor state x -> fold__$t__$c 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 '}'; +say '};;'; # fold_map functions @@ -376,12 +378,12 @@ for $adts.list -> $t say " visitor.$t.node__$t__pre_state state x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) say " visitor.$t.node__$t state x continue_fold_map >>? fun (state, new_x) ->"; # (*(fun () -> whole_adt_info, info__$t)*) say " visitor.$t.node__$t__post_state state x new_x >>? fun state ->"; # (*(fun () -> whole_adt_info, info__$t)*) - say " return (state, new_x)"; + say " return (state, new_x);;"; say ""; for $t.list -> $c { say "let _fold_map__$t__$c : type qstate . qstate mk_continue_fold_map -> qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || '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.$t__$c state x continue_fold_map"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) + say " visitor.$t.$t__$c state x continue_fold_map;;"; # (*(fun () -> whole_adt_info, info__$t, info__$t__$c)*) say ""; } } # make the "continue" object @@ -396,17 +398,17 @@ for $adts.list -> $t { say " $t__$c = (fun state x -> _fold_map__$t__$c self visitor state x) ;"; } say ' };' } say ' }'; -say '}'; +say '};;'; say ""; # fold_map functions : tying the knot say ""; for $adts.list -> $t { say "let fold_map__$t : type qstate . qstate fold_map_config -> qstate -> $t -> (qstate * $t) monad ="; - say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x"; + say " fun visitor state x -> _fold_map__$t mk_continue_fold_map visitor state x;;"; for $t.list -> $c { say "let fold_map__$t__$c : type qstate . qstate fold_map_config -> qstate -> { $c || 'unit' } -> (qstate * { $c || 'unit' }) monad ="; - say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x"; } } + say " fun visitor state x -> _fold_map__$t__$c mk_continue_fold_map visitor state x;;"; } } for $adts.list -> $t @@ -433,7 +435,7 @@ for $adts.list -> $t } else { print " v -> fold_map__$t ( "; print ( "continue.$t.$t__$_" for $t.list ).join(", "); - say " ) state v"; + say " ) state v;;"; } } @@ -455,4 +457,12 @@ for $adts.list -> $t say "let no_op : type state . state fold_map_config = \{"; for $adts.list -> $t { say " $t = no_op__$t;" } -say '}'; +say '};;'; + +say ""; +for $adts.list -> $t +{ say "let with__$t : _ = (fun node__$t op -> \{ op with $t = \{ op.$t with node__$t \} \});;"; + say "let with__$t__pre_state : _ = (fun node__$t__pre_state op -> \{ op with $t = \{ op.$t with node__$t__pre_state \} \});;"; + say "let with__$t__post_state : _ = (fun node__$t__post_state op -> \{ op with $t = \{ op.$t with node__$t__post_state \} \});;"; + for $t.list -> $c + { say "let with__$t__$c : _ = (fun $t__$c op -> \{ op with $t = \{ op.$t with $t__$c \} \});;"; } } diff --git a/src/test/adt_generator/use_a_fold.ml b/src/test/adt_generator/use_a_fold.ml index 617c5914c..f49e42c7d 100644 --- a/src/test/adt_generator/use_a_fold.ml +++ b/src/test/adt_generator/use_a_fold.ml @@ -2,6 +2,8 @@ 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 @@ -17,14 +19,13 @@ let test (x : unit result) : unit = match x with 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 = { no_op.a with - node__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 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%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -35,7 +36,8 @@ let () = 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 = { no_op.a with node__a__pre_state = fun state _the_a (*_info*) -> ok @@ 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%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -46,7 +48,7 @@ let () = 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 = { no_op.a with node__a__post_state = fun state _the_a _new_a (*_info*) -> ok @@ 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%bind (state , _) = fold_map__root op state some_root in if state != 2 then @@ -75,7 +77,7 @@ let () = | false, arg -> true, name ^ " " ^ arg) | PolyInstance { poly=_; arguments=_; poly_continue } -> (poly_continue nostate) - ); + ) ; 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) ;