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

Inlined stage common in ast_typed (fix OCaml type errors)

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-03-21 19:37:28 +01:00
parent b3b8fab26d
commit 516a3a85ff
24 changed files with 911 additions and 369 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,7 @@
open Trace
open Ligo_interpreter.Types
open Ligo_interpreter.Combinators
include Stage_common.Types
include Ast_typed.Types
module Env = Ligo_interpreter.Environment
@ -210,7 +210,7 @@ let rec apply_operator : Ast_typed.constant' -> value list -> value result =
| ( C_SET_MEM , [ v ; V_Set (elts) ] ) -> ok @@ v_bool (List.mem v elts)
| ( C_SET_REMOVE , [ v ; V_Set (elts) ] ) -> ok @@ V_Set (List.filter (fun el -> not (el = v)) elts)
| _ ->
let () = Format.printf "%a\n" Stage_common.PP.constant c in
let () = Format.printf "%a\n" Ast_typed.PP.constant c in
let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in
simple_fail "Unsupported constant op"
)
@ -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

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

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

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

@ -114,6 +114,121 @@ them. please report this to the developers." in
end
open Errors
let transpile_constant' : AST.constant' -> constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let rec transpile_type (t:AST.type_expression) : type_value result =
match t.type_content with
| T_variable (name) -> fail @@ no_type_variable @@ name
@ -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 ->

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

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

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

@ -163,6 +163,274 @@ end
open Errors
let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.Constructor c
let convert_label (I.Label c) = O.Label c
let unconvert_label (O.Label c) = I.Label c
let convert_type_constant : I.type_constant -> O.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let unconvert_type_constant : O.type_constant -> I.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let convert_constant' : I.constant' -> O.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let unconvert_constant' : O.constant' -> I.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
(*
let rec type_program (p:I.program) : O.program result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
@ -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',())

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

@ -217,6 +217,256 @@ module Errors = struct
end
open Errors
let convert_constructor' (I.Constructor c) = O.Constructor c
let unconvert_constructor' (O.Constructor c) = I.Constructor c
let convert_label (I.Label c) = O.Label c
let convert_type_constant : I.type_constant -> O.type_constant = function
| TC_unit -> TC_unit
| TC_string -> TC_string
| TC_bytes -> TC_bytes
| TC_nat -> TC_nat
| TC_int -> TC_int
| TC_mutez -> TC_mutez
| TC_bool -> TC_bool
| TC_operation -> TC_operation
| TC_address -> TC_address
| TC_key -> TC_key
| TC_key_hash -> TC_key_hash
| TC_chain_id -> TC_chain_id
| TC_signature -> TC_signature
| TC_timestamp -> TC_timestamp
| TC_void -> TC_void
let convert_constant' : I.constant' -> O.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let unconvert_constant' : O.constant' -> I.constant' = function
| C_INT -> C_INT
| C_UNIT -> C_UNIT
| C_NIL -> C_NIL
| C_NOW -> C_NOW
| C_IS_NAT -> C_IS_NAT
| C_SOME -> C_SOME
| C_NONE -> C_NONE
| C_ASSERTION -> C_ASSERTION
| C_ASSERT_INFERRED -> C_ASSERT_INFERRED
| C_FAILWITH -> C_FAILWITH
| C_UPDATE -> C_UPDATE
(* Loops *)
| C_ITER -> C_ITER
| C_FOLD_WHILE -> C_FOLD_WHILE
| C_FOLD_CONTINUE -> C_FOLD_CONTINUE
| C_FOLD_STOP -> C_FOLD_STOP
| C_LOOP_LEFT -> C_LOOP_LEFT
| C_LOOP_CONTINUE -> C_LOOP_CONTINUE
| C_LOOP_STOP -> C_LOOP_STOP
| C_FOLD -> C_FOLD
(* MATH *)
| C_NEG -> C_NEG
| C_ABS -> C_ABS
| C_ADD -> C_ADD
| C_SUB -> C_SUB
| C_MUL -> C_MUL
| C_EDIV -> C_EDIV
| C_DIV -> C_DIV
| C_MOD -> C_MOD
(* LOGIC *)
| C_NOT -> C_NOT
| C_AND -> C_AND
| C_OR -> C_OR
| C_XOR -> C_XOR
| C_LSL -> C_LSL
| C_LSR -> C_LSR
(* COMPARATOR *)
| C_EQ -> C_EQ
| C_NEQ -> C_NEQ
| C_LT -> C_LT
| C_GT -> C_GT
| C_LE -> C_LE
| C_GE -> C_GE
(* Bytes/ String *)
| C_SIZE -> C_SIZE
| C_CONCAT -> C_CONCAT
| C_SLICE -> C_SLICE
| C_BYTES_PACK -> C_BYTES_PACK
| C_BYTES_UNPACK -> C_BYTES_UNPACK
| C_CONS -> C_CONS
(* Pair *)
| C_PAIR -> C_PAIR
| C_CAR -> C_CAR
| C_CDR -> C_CDR
| C_LEFT -> C_LEFT
| C_RIGHT -> C_RIGHT
(* Set *)
| C_SET_EMPTY -> C_SET_EMPTY
| C_SET_LITERAL -> C_SET_LITERAL
| C_SET_ADD -> C_SET_ADD
| C_SET_REMOVE -> C_SET_REMOVE
| C_SET_ITER -> C_SET_ITER
| C_SET_FOLD -> C_SET_FOLD
| C_SET_MEM -> C_SET_MEM
(* List *)
| C_LIST_EMPTY -> C_LIST_EMPTY
| C_LIST_LITERAL -> C_LIST_LITERAL
| C_LIST_ITER -> C_LIST_ITER
| C_LIST_MAP -> C_LIST_MAP
| C_LIST_FOLD -> C_LIST_FOLD
(* Maps *)
| C_MAP -> C_MAP
| C_MAP_EMPTY -> C_MAP_EMPTY
| C_MAP_LITERAL -> C_MAP_LITERAL
| C_MAP_GET -> C_MAP_GET
| C_MAP_GET_FORCE -> C_MAP_GET_FORCE
| C_MAP_ADD -> C_MAP_ADD
| C_MAP_REMOVE -> C_MAP_REMOVE
| C_MAP_UPDATE -> C_MAP_UPDATE
| C_MAP_ITER -> C_MAP_ITER
| C_MAP_MAP -> C_MAP_MAP
| C_MAP_FOLD -> C_MAP_FOLD
| C_MAP_MEM -> C_MAP_MEM
| C_MAP_FIND -> C_MAP_FIND
| C_MAP_FIND_OPT -> C_MAP_FIND_OPT
(* Big Maps *)
| C_BIG_MAP -> C_BIG_MAP
| C_BIG_MAP_EMPTY -> C_BIG_MAP_EMPTY
| C_BIG_MAP_LITERAL -> C_BIG_MAP_LITERAL
(* Crypto *)
| C_SHA256 -> C_SHA256
| C_SHA512 -> C_SHA512
| C_BLAKE2b -> C_BLAKE2b
| C_HASH -> C_HASH
| C_HASH_KEY -> C_HASH_KEY
| C_CHECK_SIGNATURE -> C_CHECK_SIGNATURE
| C_CHAIN_ID -> C_CHAIN_ID
(* Blockchain *)
| C_CALL -> C_CALL
| C_CONTRACT -> C_CONTRACT
| C_CONTRACT_OPT -> C_CONTRACT_OPT
| C_CONTRACT_ENTRYPOINT -> C_CONTRACT_ENTRYPOINT
| C_CONTRACT_ENTRYPOINT_OPT -> C_CONTRACT_ENTRYPOINT_OPT
| C_AMOUNT -> C_AMOUNT
| C_BALANCE -> C_BALANCE
| C_SOURCE -> C_SOURCE
| C_SENDER -> C_SENDER
| C_ADDRESS -> C_ADDRESS
| C_SELF -> C_SELF
| C_SELF_ADDRESS -> C_SELF_ADDRESS
| C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT
| C_SET_DELEGATE -> C_SET_DELEGATE
| C_CREATE_CONTRACT -> C_CREATE_CONTRACT
let rec type_program (p:I.program) : (O.program * Solver.state) result =
let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) =
let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in
@ -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
| 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',())

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

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

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

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

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

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

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

@ -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 "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in
let lst = List.sort (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 "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m =
assert (Helpers.is_tuple_lmap m);
let lst = 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 "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT"
@ -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 "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv
| T_constant tc -> type_constant ppf tc
| T_operator to_ -> type_operator f ppf to_
and type_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, _) ->

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

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

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

@ -1,3 +1,10 @@
; (rule
; (target generated_fold.ml)
; (deps ../adt_generator/generator.raku types.ml)
; (action (with-stdout-to generated_fold.ml (run perl6 ../adt_generator/generator.raku types.ml)))
; ; (mode (promote (until-clean)))
; )
(library
(name ast_typed)
(public_name ligo.ast_typed)

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

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

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

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

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

@ -1,5 +1,6 @@
open Trace
open Types
open Helpers
module Errors = struct
let different_kinds a b () =
@ -53,7 +54,7 @@ module Errors = struct
error ~data title message ()
let different_props_in_record a b ra rb ka kb () =
let names () = if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb then "tuples" else "records" in
let names () = if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb then "tuples" else "records" in
let title () = "different keys in " ^ (names ()) in
let message () = "" in
let data = [
@ -65,8 +66,8 @@ module Errors = struct
error ~data title message ()
let different_kind_record_tuple a b ra rb () =
let name_a () = if Stage_common.Helpers.is_tuple_lmap ra then "tuple" else "record" in
let name_b () = if Stage_common.Helpers.is_tuple_lmap rb then "tuple" else "record" in
let name_a () = if Helpers.is_tuple_lmap ra then "tuple" else "record" in
let name_b () = if Helpers.is_tuple_lmap rb then "tuple" else "record" in
let title () = "different keys in " ^ (name_a ()) ^ " and " ^ (name_b ()) in
let message () = "Expected these two types to be the same, but they're different (one is a " ^ (name_a ()) ^ " and the other is a " ^ (name_b ()) ^ ")" in
let data = [
@ -82,7 +83,7 @@ module Errors = struct
let different_size_records_tuples a b ra rb =
different_size_type
(if Stage_common.Helpers.is_tuple_lmap ra && Stage_common.Helpers.is_tuple_lmap rb
(if Helpers.is_tuple_lmap ra && Helpers.is_tuple_lmap rb
then "tuples"
else "records")
a b
@ -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 _, _ ->

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

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

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

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

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

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

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

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

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

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

2
src/stages/adt_generator/dune
View File

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

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

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

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

@ -83,7 +83,7 @@ module Substitution = struct
| None -> ok @@ T.T_variable variable
end
| T.T_operator type_name_and_args ->
let%bind type_name_and_args = T.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in
let%bind type_name_and_args = T.Helpers.bind_map_type_operator (s_type_expression ~substs) type_name_and_args in
ok @@ T.T_operator type_name_and_args
| T.T_arrow _ ->
let _TODO = substs in

2
src/test/typer_tests.ml
View File

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