Commit 10e00243 authored by Max's avatar Max

Merge branch 'love-update' into 'next'

Ui/Forge: update love encoding

See merge request !48
parents 1607a927 dec111af
......@@ -249,9 +249,9 @@ let check_int64 s =
let check_z s =
let s = to_string s in
try ignore @@ Z.of_string s; Ok () with _ -> Error ["cannot read zarith " ^ s]
let check_script_expr s =
let check_script_expr ?contract s =
let s = to_string s in
try ignore @@ Dune_encoding_min.Script.decode s; Ok ()
try ignore @@ Dune_script.parse_script ?contract s; Ok ()
with _ -> Error ["cannot decode script " ^ s]
let check_parameters (o: parameters_js t) =
check_optdef check_script_expr o##.value
......@@ -267,8 +267,8 @@ let check_enum l ls =
| Some (Ok _) -> Ok ()
let check_script (o: script_js t) =
check_list [
check_optdef check_script_expr o##.code;
check_script_expr o##.storage;
check_optdef (check_script_expr ~contract:true) o##.code;
check_script_expr ~contract:true o##.storage;
check_enum [ o##.code; o##.codeHash ] ["code"; "code_hash" ]
]
let check_notif_manager_info (o: notif_manager_info_js t) =
......
......@@ -65,7 +65,10 @@ let parse_love ?(contract=false) s =
| Love_value.Type t -> Ok Dune_types_min.(DuneExpr (LoveExpr (LoveType t))))
with _ -> Error (Async.Str_err ("Cannot parse love " ^ s))
let parse_script ?contract s = match fst (get_header s) with
let parse_script ?contract s =
let h, i = get_header s in
let s = String.trim @@ String.sub s i ((String.length s) - i) in
match h with
| Some "mic" -> parse_micheline s
| Some "love" -> parse_love ?contract s
| Some "json" -> parse_json s
......@@ -73,10 +76,12 @@ let parse_script ?contract s = match fst (get_header s) with
| None -> parse_json s
(* string to json *)
let json_of_string s = match get_header s with
| Some "mic", i -> let s = (String.sub s i ((String.length s) - i)) in
parse_micheline s >|? Dune_encoding_min.Script.encode
| Some "love", _ -> parse_love s >|? Dune_encoding_min.Script.encode
| Some "json", i -> Ok (String.sub s i ((String.length s) - i))
| Some s, _ -> Error (Async.Str_err ("Cannot parse header " ^ s))
| None, _ -> Ok s
let json_of_string ?contract s =
let h, i = get_header s in
let s = String.trim @@ String.sub s i ((String.length s) - i) in
match h with
| Some "mic" -> parse_micheline s >|? Dune_encoding_min.Script.encode
| Some "love" -> parse_love ?contract s >|? Dune_encoding_min.Script.encode
| Some "json" -> Ok s
| Some s -> Error (Async.Str_err ("Cannot parse header " ^ s))
| None -> Ok s
oflags = [ "-g"; "-w"; "+a-48-4-44-45-41-42"; ];
ocaml.bytecomp = oflags;
ocaml.asmcomp = oflags;
OCaml.library("love-common", ocaml+{
requires = [ "metal-binary" ];
......
......@@ -211,8 +211,8 @@ let pp_type_kind fmt k =
let type_kind_to_sigtype = function
| TPublic -> (fun td -> Some (Love_type.SPublic td))
| TPrivate -> (fun td -> Some (Love_type.SPrivate td))
| TAbstract -> (fun td -> (Some (Love_type.SAbstract (Love_type.typedef_parameters td))))
| TPrivate -> (fun td -> Some (SPrivate td))
| TAbstract -> (fun td -> (Some (SAbstract (Love_type.typedef_parameters td))))
| TInternal -> (fun _ -> None)
let exn_id = function
......@@ -232,8 +232,8 @@ let exn_equal e1 e2 =
let is_module c =
match c.kind with
| Love_type.Module -> true
| Love_type.Contract _ -> false
| Module -> true
| Contract _ -> false
let compare_annot l1 l2 = compare_option compare_location l1 l2
......@@ -281,16 +281,16 @@ let compare_extended_arg a1 a2 =
let open Love_primitive in
match a1, a2 with
| AType t1, AType t2 -> Love_type.compare t1 t2
| AContractType (Love_type.StructType st1),
AContractType (Love_type.StructType st2) ->
| AContractType (StructType st1),
AContractType (StructType st2) ->
Love_type.compare_struct_type st1 st2
| AContractType (Love_type.ContractInstance id1),
AContractType (Love_type.ContractInstance id2) ->
| AContractType (ContractInstance id1),
AContractType (ContractInstance id2) ->
Ident.compare String.compare id1 id2
| AContractType (Love_type.StructType _),
AContractType (Love_type.ContractInstance _) -> -1
| AContractType (Love_type.ContractInstance _),
AContractType (Love_type.StructType _) -> 1
| AContractType (StructType _),
AContractType (ContractInstance _) -> -1
| AContractType (ContractInstance _),
AContractType (StructType _) -> 1
| AType _, AContractType _ -> -1
| AContractType _, AType _ -> 1
......
......@@ -142,7 +142,7 @@ module Serializer = struct
let ser_rec state = function
| Love_type.NonRec -> LBB.write_bool state false
| Love_type.Rec -> LBB.write_bool state true
| Rec -> LBB.write_bool state true
(** Type serializers **)
......@@ -283,7 +283,7 @@ module Serializer = struct
let ser_annoted ser state annoted =
ser state annoted.Utils.content;
AnnotSerializer.ser_annot state annoted.Utils.annot
AnnotSerializer.ser_annot state annoted.annot
let ser_exn_name state = function
| Love_ast.Fail t -> LBB.write_bool state true; Type.ser_type state t
......@@ -795,16 +795,16 @@ module Serializer = struct
ser_x_y_pair ser_value ser_live_contract state script;
ser_dun state credit;
ser_x_option ser_address state preorigination
| Op.Transaction { amount; parameters; entrypoint; destination } ->
| Transaction { amount; parameters; entrypoint; destination } ->
write state 1;
ser_dun state amount;
ser_x_option ser_value state parameters;
LBB.write_str_repr state entrypoint;
ser_address state destination;
| Op.Delegation delegate ->
| Delegation delegate ->
write state 2;
ser_x_option ser_key_hash state delegate;
| Op.Dune_manage_account
| Dune_manage_account
{ target; maxrolls; admin; white_list; delegation } ->
write state 3;
ser_x_option ser_key_hash state target;
......@@ -827,14 +827,14 @@ module Serializer = struct
ser_value state diff_key;
ser_script_expr_hash state diff_key_hash;
ser_x_option ser_value state diff_value
| Op.Clear id ->
| Clear id ->
write state 1;
LBB.write_z state id
| Op.Copy (ids, idd) ->
| Copy (ids, idd) ->
write state 2;
LBB.write_z state ids;
LBB.write_z state idd
| Op.Alloc { big_map; key_type; value_type } ->
| Alloc { big_map; key_type; value_type } ->
write state 3;
LBB.write_z state big_map;
Type.ser_type state key_type;
......@@ -848,17 +848,17 @@ module Serializer = struct
(** Structure serializers **)
and ser_init state
(LiveStructure.{ vinit_code; vinit_typ; vinit_persist } : LiveStructure.init) =
({ vinit_code; vinit_typ; vinit_persist } : LiveStructure.init) =
ser_value state vinit_code; Type.ser_type state vinit_typ;
LBB.write_bool state vinit_persist;
and ser_entry state
(LiveStructure.{ ventry_code; ventry_fee_code; ventry_typ } : LiveStructure.entry) =
({ ventry_code; ventry_fee_code; ventry_typ } : LiveStructure.entry) =
ser_value state ventry_code;
ser_x_option ser_value state ventry_fee_code;
Type.ser_type state ventry_typ
and ser_view state (LiveStructure.{ vview_code; vview_typ } : LiveStructure.view) =
and ser_view state ({ vview_code; vview_typ } : LiveStructure.view) =
ser_value state vview_code;
ser_x_x_pair Type.ser_type state vview_typ
......@@ -1041,7 +1041,7 @@ module Deserializer = struct
if LBB.read_bool state then Public else Private
let des_rec state = if LBB.read_bool state then Love_type.Rec else Love_type.NonRec
let des_rec state = if LBB.read_bool state then Love_type.Rec else NonRec
(** Type deserializers **)
......@@ -1786,16 +1786,16 @@ module Deserializer = struct
let diff_value = des_x_option des_value state in
Op.Update { big_map; diff_key; diff_key_hash; diff_value }
| 1 ->
Op.Clear (LBB.read_z state)
Clear (LBB.read_z state)
| 2 ->
let ids = LBB.read_z state in
let idd = LBB.read_z state in
Op.Copy (ids, idd)
Copy (ids, idd)
| 3 ->
let big_map = LBB.read_z state in
let key_type = Type.des_type state in
let value_type = Type.des_type state in
Op.Alloc { big_map; key_type; value_type }
Alloc { big_map; key_type; value_type }
| i -> raise (DeserializeError (i, "Unknown big map diff item"))
and des_op state =
......@@ -1810,18 +1810,18 @@ module Deserializer = struct
let vinit_code = des_value state in
let vinit_typ = Type.des_type state in
let vinit_persist = LBB.read_bool state in
(LiveStructure.{ vinit_code; vinit_typ; vinit_persist } : LiveStructure.init)
({ vinit_code; vinit_typ; vinit_persist } : LiveStructure.init)
and des_entry state =
let ventry_code = des_value state in
let ventry_fee_code = des_x_option des_value state in
let ventry_typ = Type.des_type state in
(LiveStructure.{ ventry_code; ventry_fee_code; ventry_typ } : LiveStructure.entry)
({ ventry_code; ventry_fee_code; ventry_typ } : LiveStructure.entry)
and des_view state =
let vview_code = des_value state in
let vview_typ = des_x_x_pair Type.des_type state in
(LiveStructure.{ vview_code; vview_typ } : LiveStructure.view)
({ vview_code; vview_typ } : LiveStructure.view)
and des_cvalue state =
let vvalue_code = des_value state in
......
This diff is collapsed.
This diff is collapsed.
......@@ -165,8 +165,8 @@ let unique_tvars_in_tdef td =
Alias { aparams = param_list;
atype = replace_map (fun _ -> true) tvarmap atype }
let loc ((Lexing.{ pos_fname = _; pos_lnum; pos_bol = pb1; pos_cnum = cn1 },
Lexing.{ pos_fname = _; pos_lnum = _; pos_bol = pb2; pos_cnum = cn2 }) :
let loc (({ pos_fname = _; pos_lnum; pos_bol = pb1; pos_cnum = cn1 },
{ pos_fname = _; pos_lnum = _; pos_bol = pb2; pos_cnum = cn2 }) :
Lexing.position * Lexing.position ) : Love_ast.location =
{ pos_lnum; pos_bol = pb2 - pb1; pos_cnum = cn2 - cn1 }
......@@ -227,7 +227,7 @@ let top_val_or_entry l ea a r n pl rt e fc =
match rt with
None -> ()
| Some (TTuple [
TUser (Ident.LName "list", [TUser (Ident.LName "operation", [])]);
TUser (LName "list", [TUser (LName "operation", [])]);
TUser (tn, _)
]
) ->
......@@ -890,11 +890,7 @@ pattern_common:
{ mk_ptuple ~loc:(loc ($startpos, $endpos)) pl }
| p1 = pattern COLONCOLON p2 = pattern
{ match p2.content with
| PList [] ->
if has_revision 3 then
{ p2 with content = PList (p1 :: [p2]) }
else
{ p2 with content = PList (p1 :: []) }
| PList [] -> { p2 with content = PList (p1 :: [p2]) }
| PList pl -> { p2 with content = PList (p1 :: pl) }
| _ -> { p2 with content = PList [p1; p2] }
}
......
......@@ -21,6 +21,8 @@ open Shortcut
module Options = struct
(* GLOBAL_STATE *)
(** Activates debug messages *)
let debug = ref false
......@@ -59,6 +61,7 @@ module Log = struct
out_indent = (fun _ -> ());
}
(* GLOBAL_STATE *)
let fmt = ref (fun _ -> dummy_formatter)
let print (msg: ('a, Format.formatter, unit) format) : 'a =
......@@ -410,7 +413,7 @@ module Path = struct
let path_of_id i =
let rec loop res = function
Ident.LDot (n,i) -> loop (Next n :: res) i
| Ident.LName n -> List.rev res, n
| LName n -> List.rev res, n
in loop [] i
end
......@@ -441,6 +444,7 @@ module Collections = struct
let add_list bindings m =
List.fold_left (fun m (v, c) -> add v c m) m (List.rev bindings)
end
end
......@@ -456,14 +460,14 @@ module Constants = struct
end
(* GLOBAL_STATE *)
let revision = ref (-1)
let update_revision r =
let update_protocol_revision r =
if Compare.Int.(!revision = r) then false
else (revision := r; true)
let has_revision r =
let has_protocol_revision r =
if Compare.Int.(!revision < 0) then
failwith "Love : Revision not set"
else
......
This diff is collapsed.
......@@ -189,8 +189,8 @@ let exn_equal e1 e2 =
let is_module c =
match c.kind with
| Love_type.Module -> true
| Love_type.Contract _ -> false
| Module -> true
| Contract _ -> false
......
......@@ -31,6 +31,7 @@ type core_type = {
let def_type_to_type dt params = dt.ct_ty params
(* GLOBAL_STATE *)
let all_types : core_type Collections.StringMap.t ref = ref Collections.StringMap.empty
let register name tdef =
......@@ -130,6 +131,8 @@ let tv = Love_type.fresh_typevar
(** Type registration *)
let init () =
all_types := Collections.StringMap.empty ;
register_core "unit" [] comparable;
register_core "bool" [] comparable;
register_core "int" [] comparable;
......@@ -146,13 +149,13 @@ let init () =
register_core "operation" [] default_trait;
register_core "list" [tv ~name:"@'list_elt" ~tv_traits:default_trait ()]
(if Love_pervasives.has_revision 3 then comparable else default_trait);
(if Love_pervasives.has_protocol_revision 3 then comparable else default_trait);
register_core "set" [tv ~name:"@'set_elt" ~tv_traits:comparable ()] comparable;
register_core
"map"
[tv ~name:"@'map_key" ~tv_traits:comparable ();
tv ~name:"@'map_key" ~tv_traits:default_trait ()]
comparable;
(if Love_pervasives.has_protocol_revision 3 then comparable else default_trait);
register_core
"bigmap"
......
......@@ -682,7 +682,7 @@ end = struct
content : (string * content) list;
}
let unit = { content = []; kind = Love_type.Contract [] }
let unit = { content = []; kind = Contract [] }
let resolve_id_in_struct (s : LiveStructure.t) (id : string Ident.t) =
let open LiveStructure in
......@@ -692,7 +692,7 @@ end = struct
| Some _ | None -> None
) (Some (VStructure s)) (Ident.get_list id)
let is_module c = match c.kind with Love_type.Module -> true | Love_type.Contract _ -> false
let is_module c = match c.kind with Module -> true | Contract _ -> false
let rec raw_compare_content c1 c2 =
......@@ -779,7 +779,7 @@ end = FeeCode
let normalize_contract (contract : LiveContract.t) =
contract, FeeCode.{ version = contract.LiveContract.version;
contract, FeeCode.{ version = contract.version;
root_struct = LiveStructure.unit;
fee_codes = [];
}
......@@ -792,15 +792,15 @@ let rec sig_of_structure ~only_typedefs
let sig_content =
List.fold_left (fun acc (n, content) ->
match content with
| VType (Love_ast.TInternal, _td) -> acc
| VType (Love_ast.TPublic, td) ->
| VType (TInternal, _td) -> acc
| VType (TPublic, td) ->
let () =
match kind with
Contract _ when String.equal n "storage" -> has_storage := true
| _ -> () in
(n, SType (SPublic td)) :: acc
| VType (Love_ast.TPrivate, td) -> (n, SType (SPrivate td)) :: acc
| VType (Love_ast.TAbstract, td) ->
| VType (TPrivate, td) -> (n, SType (SPrivate td)) :: acc
| VType (TAbstract, td) ->
let params = match td with
| Alias { aparams = p; _ }
| SumType { sparams = p; _ }
......@@ -812,10 +812,10 @@ let rec sig_of_structure ~only_typedefs
(n, SEntry tparam) :: acc
| VView { vview_typ = (tparam, treturn);_ } when not only_typedefs ->
(n, SView (tparam, treturn)) :: acc
| VValue { vvalue_typ; vvalue_visibility = Love_ast.Public; _ }
| VValue { vvalue_typ; vvalue_visibility = Public; _ }
when not only_typedefs ->
(n, SValue vvalue_typ) :: acc
| VValue { vvalue_visibility = Love_ast.Private; _ } -> acc
| VValue { vvalue_visibility = Private; _ } -> acc
| VStructure s ->
(n, SStructure (Anonymous (sig_of_structure ~only_typedefs s))) :: acc
| VSignature s ->
......
......@@ -2,6 +2,10 @@ open Dune_types_min
open Metal_types
open Async
let script_to_json ?contract s = match Dune_script.json_of_string ?contract s with
| Error _ -> s
| Ok s -> s
let dune_op ?sign_target ~src {mo_det; mo_info} =
let fee = Misc.unopt 0L mo_info.not_mi_fee in
let gas_limit = Misc.unopt Z.zero mo_info.not_mi_gas_limit in
......@@ -20,7 +24,10 @@ let dune_op ?sign_target ~src {mo_det; mo_info} =
node_tr_collect_fee_gas = None;
node_tr_collect_pk = None;
node_tr_entrypoint = Misc.unoptf None fst trd.trd_parameters;
node_tr_parameters = Misc.unoptf None snd trd.trd_parameters;
node_tr_parameters =
Misc.unoptf None (fun (_e, v) ->
Misc.convopt script_to_json v)
trd.trd_parameters;
node_tr_metadata = None;
}))
| OriDetails ord ->
......@@ -32,6 +39,8 @@ let dune_op ?sign_target ~src {mo_det; mo_info} =
node_or_storage_limit = storage_limit;
node_or_balance = ord.ord_balance;
node_or_script = Misc.convopt (fun (sc_code, sc_storage, sc_code_hash) ->
let sc_code = Misc.convopt (script_to_json ~contract:true) sc_code in
let sc_storage = script_to_json sc_storage in
{sc_code; sc_storage; sc_code_hash}) ord.ord_script;
node_or_metadata = None ;
}))
......
......@@ -824,7 +824,6 @@ let update_balance state =
txt "--" ])
state.fo_acc.pkh
(fun {Dune_types_min.node_ai_balance; _} ->
Js_utils.log "TEST3";
replace1 main_balance_value_id
(Dun.pp_amount node_ai_balance)) in
Timer.clear_create ~name:"balance" 30 cb
......
......@@ -299,6 +299,11 @@ let notif_kind_to_row network = function
txt n.not_approv_name ] ;
]
let print_script ?contract s =
match Dune_script.parse_script ?contract s with
| Error _ -> s
| Ok sc -> Dune_script.print_script ?contract sc
let add_param params acc = match params with
| None -> acc
| Some (e, v) ->
......@@ -308,8 +313,7 @@ let add_param params acc = match params with
match v with
| None -> acc
| Some p ->
let sc = Dune_encoding_min.Script.decode p in
let p = Dune_script.print_script sc in
let p = print_script p in
div ~a:[ a_class [ Display.d_flex ] ] [
div ~a:[ a_class [ Flex.flex_fill ] ]
[ div ~a:[ a_class [ "param" ] ] ([
......@@ -322,8 +326,7 @@ let add_param params acc = match params with
let add_script sc acc = match sc with
| Some (Some sc, _, _) ->
let sc = Dune_encoding_min.Script.decode sc in
let sc = Dune_script.print_script ~contract:true sc in
let sc = print_script ~contract:true sc in
div ~a:[ a_class [ Display.d_flex ] ] [
div ~a:[ a_class [ Flex.flex_fill ] ]
[ div ~a:[ a_class [ "param" ] ] [
......@@ -335,8 +338,7 @@ let add_script sc acc = match sc with
let add_storage sc acc = match sc with
| Some (_, sc, _) ->
let sc = Dune_encoding_min.Script.decode sc in
let sc = Dune_script.print_script sc in
let sc = print_script sc in
div ~a:[ a_class [ Display.d_flex ] ] [
div ~a:[ a_class [ Flex.flex_fill ] ]
[ div ~a:[ a_class [ "param" ] ] [
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment