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

[does not build] Inlined stage common in ast_typed

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-03-17 15:30:38 +01:00
parent 08aefa4580
commit b3b8fab26d
5 changed files with 742 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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
)

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

@ -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 =

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

@ -0,0 +1,165 @@
open Types
open Trace
let map_type_operator f = function
TC_contract x -> TC_contract (f x)
| TC_option x -> TC_option (f x)
| TC_list x -> TC_list (f x)
| TC_set x -> TC_set (f x)
| TC_map (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

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

@ -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 , _) =

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

@ -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