diff --git a/src/lib_micheline/micheline.ml b/src/lib_micheline/micheline.ml index 0cff3eabd..0127bdd88 100644 --- a/src/lib_micheline/micheline.ml +++ b/src/lib_micheline/micheline.ml @@ -23,279 +23,5 @@ (* *) (*****************************************************************************) -type annot = string list - -type ('l, 'p) node = - | Int of 'l * Z.t - | String of 'l * string - | Bytes of 'l * MBytes.t - | Prim of 'l * 'p * ('l, 'p) node list * annot - | Seq of 'l * ('l, 'p) node list - -type canonical_location = int - -type 'p canonical = Canonical of (canonical_location, 'p) node - -let canonical_location_encoding = - let open Data_encoding in - def - "micheline.location" - ~title: - "Canonical location in a Micheline expression" - ~description: - "The location of a node in a Micheline expression tree \ - in prefix order, with zero being the root and adding one \ - for every basic node, sequence and primitive application." @@ - int31 - -let location = function - | Int (loc, _) -> loc - | String (loc, _) -> loc - | Bytes (loc, _) -> loc - | Seq (loc, _) -> loc - | Prim (loc, _, _, _) -> loc - -let annotations = function - | Int (_, _) -> [] - | String (_, _) -> [] - | Bytes (_, _) -> [] - | Seq (_, _) -> [] - | Prim (_, _, _, annots) -> annots - -let root (Canonical expr) = expr - -let strip_locations root = - let id = let id = ref (-1) in fun () -> incr id ; !id in - let rec strip_locations l = - let id = id () in - match l with - | Int (_, v) -> - Int (id, v) - | String (_, v) -> - String (id, v) - | Bytes (_, v) -> - Bytes (id, v) - | Seq (_, seq) -> - Seq (id, List.map strip_locations seq) - | Prim (_, name, seq, annots) -> - Prim (id, name, List.map strip_locations seq, annots) in - Canonical (strip_locations root) - -let extract_locations root = - let id = let id = ref (-1) in fun () -> incr id ; !id in - let loc_table = ref [] in - let rec strip_locations l = - let id = id () in - match l with - | Int (loc, v) -> - loc_table := (id, loc) :: !loc_table ; - Int (id, v) - | String (loc, v) -> - loc_table := (id, loc) :: !loc_table ; - String (id, v) - | Bytes (loc, v) -> - loc_table := (id, loc) :: !loc_table ; - Bytes (id, v) - | Seq (loc, seq) -> - loc_table := (id, loc) :: !loc_table ; - Seq (id, List.map strip_locations seq) - | Prim (loc, name, seq, annots) -> - loc_table := (id, loc) :: !loc_table ; - Prim (id, name, List.map strip_locations seq, annots) in - let stripped = strip_locations root in - Canonical stripped, List.rev !loc_table - -let inject_locations lookup (Canonical root) = - let rec inject_locations l = - match l with - | Int (loc, v) -> - Int (lookup loc, v) - | String (loc, v) -> - String (lookup loc, v) - | Bytes (loc, v) -> - Bytes (lookup loc, v) - | Seq (loc, seq) -> - Seq (lookup loc, List.map inject_locations seq) - | Prim (loc, name, seq, annots) -> - Prim (lookup loc, name, List.map inject_locations seq, annots) in - inject_locations root - -let map f (Canonical expr) = - let rec map_node f = function - | Int _ | String _ | Bytes _ as node -> node - | Seq (loc, seq) -> - Seq (loc, List.map (map_node f) seq) - | Prim (loc, name, seq, annots) -> - Prim (loc, f name, List.map (map_node f) seq, annots) in - Canonical (map_node f expr) - -let rec map_node fl fp = function - | Int (loc, v) -> - Int (fl loc, v) - | String (loc, v) -> - String (fl loc, v) - | Bytes (loc, v) -> - Bytes (fl loc, v) - | Seq (loc, seq) -> - Seq (fl loc, List.map (map_node fl fp) seq) - | Prim (loc, name, seq, annots) -> - Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots) - -type semantics = V0 | V1 - -let internal_canonical_encoding ~semantics ~variant prim_encoding = - let open Data_encoding in - let int_encoding = - obj1 (req "int" z) in - let string_encoding = - obj1 (req "string" string) in - let bytes_encoding = - obj1 (req "bytes" bytes) in - let int_encoding tag = - case tag int_encoding - ~title:"Int" - (function Int (_, v) -> Some v | _ -> None) - (fun v -> Int (0, v)) in - let string_encoding tag = - case tag string_encoding - ~title:"String" - (function String (_, v) -> Some v | _ -> None) - (fun v -> String (0, v)) in - let bytes_encoding tag = - case tag bytes_encoding - ~title:"Bytes" - (function Bytes (_, v) -> Some v | _ -> None) - (fun v -> Bytes (0, v)) in - let seq_encoding tag expr_encoding = - case tag (list expr_encoding) - ~title:"Sequence" - (function Seq (_, v) -> Some v | _ -> None) - (fun args -> Seq (0, args)) in - let annots_encoding = - let split s = - if s = "" && semantics <> V0 then [] - else - let annots = String.split_on_char ' ' s in - List.iter (fun a -> - if String.length a > 255 then failwith "Oversized annotation" - ) annots; - if String.concat " " annots <> s then - failwith "Invalid annotation string, \ - must be a sequence of valid annotations with spaces" ; - annots in - splitted - ~json:(list (Bounded.string 255)) - ~binary:(conv (String.concat " ") split string) in - let application_encoding tag expr_encoding = - case tag - ~title:"Generic prim (any number of args with or without annot)" - (obj3 (req "prim" prim_encoding) - (dft "args" (list expr_encoding) []) - (dft "annots" annots_encoding [])) - (function Prim (_, prim, args, annots) -> Some (prim, args, annots) - | _ -> None) - (fun (prim, args, annots) -> Prim (0, prim, args, annots)) in - let node_encoding = mu ("micheline." ^ variant ^ ".expression") (fun expr_encoding -> - splitted - ~json:(union ~tag_size:`Uint8 - [ int_encoding Json_only; - string_encoding Json_only ; - bytes_encoding Json_only ; - seq_encoding Json_only expr_encoding ; - application_encoding Json_only expr_encoding ]) - ~binary:(union ~tag_size:`Uint8 - [ int_encoding (Tag 0) ; - string_encoding (Tag 1) ; - seq_encoding (Tag 2) expr_encoding ; - (* No args, no annot *) - case (Tag 3) - ~title:"Prim (no args, annot)" - (obj1 (req "prim" prim_encoding)) - (function Prim (_, v, [], []) -> Some v - | _ -> None) - (fun v -> Prim (0, v, [], [])) ; - (* No args, with annots *) - case (Tag 4) - ~title:"Prim (no args + annot)" - (obj2 (req "prim" prim_encoding) - (req "annots" annots_encoding)) - (function - | Prim (_, v, [], annots) -> Some (v, annots) - | _ -> None) - (function (prim, annots) -> Prim (0, prim, [], annots)) ; - (* Single arg, no annot *) - case (Tag 5) - ~title:"Prim (1 arg, no annot)" - (obj2 (req "prim" prim_encoding) - (req "arg" expr_encoding)) - (function - | Prim (_, v, [ arg ], []) -> Some (v, arg) - | _ -> None) - (function (prim, arg) -> Prim (0, prim, [ arg ], [])) ; - (* Single arg, with annot *) - case (Tag 6) - ~title:"Prim (1 arg + annot)" - (obj3 (req "prim" prim_encoding) - (req "arg" expr_encoding) - (req "annots" annots_encoding)) - (function - | Prim (_, prim, [ arg ], annots) -> Some (prim, arg, annots) - | _ -> None) - (fun (prim, arg, annots) -> Prim (0, prim, [ arg ], annots)) ; - (* Two args, no annot *) - case (Tag 7) - ~title:"Prim (2 args, no annot)" - (obj3 (req "prim" prim_encoding) - (req "arg1" expr_encoding) - (req "arg2" expr_encoding)) - (function - | Prim (_, prim, [ arg1 ; arg2 ], []) -> Some (prim, arg1, arg2) - | _ -> None) - (fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], [])) ; - (* Two args, with annots *) - case (Tag 8) - ~title:"Prim (2 args + annot)" - (obj4 (req "prim" prim_encoding) - (req "arg1" expr_encoding) - (req "arg2" expr_encoding) - (req "annots" annots_encoding)) - (function - | Prim (_, prim, [ arg1 ; arg2 ], annots) -> Some (prim, arg1, arg2, annots) - | _ -> None) - (fun (prim, arg1, arg2, annots) -> Prim (0, prim, [ arg1 ; arg2 ], annots)) ; - (* General case *) - application_encoding (Tag 9) expr_encoding ; - bytes_encoding (Tag 10) ])) - in - conv - (function Canonical node -> node) - (fun node -> strip_locations node) - node_encoding - -let canonical_encoding ~variant prim_encoding = - internal_canonical_encoding ~semantics:V1 ~variant prim_encoding -let canonical_encoding_v1 ~variant prim_encoding = - internal_canonical_encoding ~semantics:V1 ~variant prim_encoding -let canonical_encoding_v0 ~variant prim_encoding = - internal_canonical_encoding ~semantics:V0 ~variant prim_encoding - -let table_encoding ~variant location_encoding prim_encoding = - let open Data_encoding in - conv - (fun node -> - let canon, assoc = extract_locations node in - let _, table = List.split assoc in - (canon, table)) - (fun (canon, table) -> - let table = Array.of_list table in - inject_locations (fun i -> table.(i)) canon) - (obj2 - (req "expression" (canonical_encoding ~variant prim_encoding)) - (req "locations" (list location_encoding))) - -let erased_encoding ~variant default_location prim_encoding = - let open Data_encoding in - conv - (fun node -> strip_locations node) - (fun canon -> inject_locations (fun _ -> default_location) canon) - (canonical_encoding ~variant prim_encoding) +include Micheline_main +module Michelson_primitives = Michelson_primitives diff --git a/src/lib_micheline/micheline.mli b/src/lib_micheline/micheline.mli index 49cb40c56..172aab55c 100644 --- a/src/lib_micheline/micheline.mli +++ b/src/lib_micheline/micheline.mli @@ -23,82 +23,6 @@ (* *) (*****************************************************************************) -type annot = string list +include module type of Micheline_main +module Michelson_primitives = Michelson_primitives -(** The abstract syntax tree of Micheline expressions. The first - parameter is used to contain locations, but can also embed custom - data. The second parameter is the type of primitive names. *) -type ('l, 'p) node = - | Int of 'l * Z.t - | String of 'l * string - | Bytes of 'l * MBytes.t - | Prim of 'l * 'p * ('l, 'p) node list * annot - | Seq of 'l * ('l, 'p) node list - -(** Encoding for expressions, as their {!canonical} encoding. - Locations are stored in a side table. - See {!canonical_encoding} for the [variant] parameter. *) -val table_encoding : variant:string -> - 'l Data_encoding.encoding -> 'p Data_encoding.encoding -> - ('l, 'p) node Data_encoding.encoding - -(** Encoding for expressions, as their {!canonical} encoding. - Locations are erased when serialized, and restored to a provided - default value when deserialized. - See {!canonical_encoding} for the [variant] parameter. *) -val erased_encoding : variant:string -> - 'l -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding - -(** Extract the location of the node. *) -val location : ('l, 'p) node -> 'l - -(** Extract the annotations of the node. *) -val annotations : ('l, 'p) node -> string list - -(** Expression form using canonical integer numbering as - locations. The root has number zero, and each node adds one in the - order of infix traversal. To be used when locations are not - important, or when one wants to attach properties to nodes in an - expression without rewriting it (using an indirection table with - canonical locations as keys). *) -type 'p canonical - -(** Canonical integer locations that appear inside {!canonical} expressions. *) -type canonical_location = int - -(** Encoding for canonical integer locations. *) -val canonical_location_encoding : canonical_location Data_encoding.encoding - -(** Encoding for expressions in canonical form. The first parameter - is a name used to produce named definitions in the schemas. Make - sure to use different names if two expression variants with - different primitive encodings are used in the same schema. *) -val canonical_encoding : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding - -(** Old version of {!canonical_encoding} for retrocompatibility. - Do not use in new code. *) -val canonical_encoding_v0 : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding - -(** Alias for {!canonical_encoding}. *) -val canonical_encoding_v1 : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding - -(** Compute the canonical form of an expression. - Drops the concrete locations completely. *) -val strip_locations : (_, 'p) node -> 'p canonical - -(** Give the root node of an expression in canonical form. *) -val root : 'p canonical -> (canonical_location, 'p) node - -(** Compute the canonical form of an expression. - Saves the concrete locations in an association list. *) -val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list - -(** Transforms an expression in canonical form into a polymorphic one. - Takes a mapping function to inject the concrete locations. *) -val inject_locations : (canonical_location -> 'l) -> 'p canonical -> ('l, 'p) node - -(** Copies the tree, updating its primitives. *) -val map : ('a -> 'b) -> 'a canonical -> 'b canonical - -(** Copies the tree, updating its primitives and locations. *) -val map_node : ('la -> 'lb) -> ('pa -> 'pb) -> ('la, 'pa) node -> ('lb, 'pb) node diff --git a/src/lib_micheline/micheline_main.ml b/src/lib_micheline/micheline_main.ml new file mode 100644 index 000000000..0cff3eabd --- /dev/null +++ b/src/lib_micheline/micheline_main.ml @@ -0,0 +1,301 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type annot = string list + +type ('l, 'p) node = + | Int of 'l * Z.t + | String of 'l * string + | Bytes of 'l * MBytes.t + | Prim of 'l * 'p * ('l, 'p) node list * annot + | Seq of 'l * ('l, 'p) node list + +type canonical_location = int + +type 'p canonical = Canonical of (canonical_location, 'p) node + +let canonical_location_encoding = + let open Data_encoding in + def + "micheline.location" + ~title: + "Canonical location in a Micheline expression" + ~description: + "The location of a node in a Micheline expression tree \ + in prefix order, with zero being the root and adding one \ + for every basic node, sequence and primitive application." @@ + int31 + +let location = function + | Int (loc, _) -> loc + | String (loc, _) -> loc + | Bytes (loc, _) -> loc + | Seq (loc, _) -> loc + | Prim (loc, _, _, _) -> loc + +let annotations = function + | Int (_, _) -> [] + | String (_, _) -> [] + | Bytes (_, _) -> [] + | Seq (_, _) -> [] + | Prim (_, _, _, annots) -> annots + +let root (Canonical expr) = expr + +let strip_locations root = + let id = let id = ref (-1) in fun () -> incr id ; !id in + let rec strip_locations l = + let id = id () in + match l with + | Int (_, v) -> + Int (id, v) + | String (_, v) -> + String (id, v) + | Bytes (_, v) -> + Bytes (id, v) + | Seq (_, seq) -> + Seq (id, List.map strip_locations seq) + | Prim (_, name, seq, annots) -> + Prim (id, name, List.map strip_locations seq, annots) in + Canonical (strip_locations root) + +let extract_locations root = + let id = let id = ref (-1) in fun () -> incr id ; !id in + let loc_table = ref [] in + let rec strip_locations l = + let id = id () in + match l with + | Int (loc, v) -> + loc_table := (id, loc) :: !loc_table ; + Int (id, v) + | String (loc, v) -> + loc_table := (id, loc) :: !loc_table ; + String (id, v) + | Bytes (loc, v) -> + loc_table := (id, loc) :: !loc_table ; + Bytes (id, v) + | Seq (loc, seq) -> + loc_table := (id, loc) :: !loc_table ; + Seq (id, List.map strip_locations seq) + | Prim (loc, name, seq, annots) -> + loc_table := (id, loc) :: !loc_table ; + Prim (id, name, List.map strip_locations seq, annots) in + let stripped = strip_locations root in + Canonical stripped, List.rev !loc_table + +let inject_locations lookup (Canonical root) = + let rec inject_locations l = + match l with + | Int (loc, v) -> + Int (lookup loc, v) + | String (loc, v) -> + String (lookup loc, v) + | Bytes (loc, v) -> + Bytes (lookup loc, v) + | Seq (loc, seq) -> + Seq (lookup loc, List.map inject_locations seq) + | Prim (loc, name, seq, annots) -> + Prim (lookup loc, name, List.map inject_locations seq, annots) in + inject_locations root + +let map f (Canonical expr) = + let rec map_node f = function + | Int _ | String _ | Bytes _ as node -> node + | Seq (loc, seq) -> + Seq (loc, List.map (map_node f) seq) + | Prim (loc, name, seq, annots) -> + Prim (loc, f name, List.map (map_node f) seq, annots) in + Canonical (map_node f expr) + +let rec map_node fl fp = function + | Int (loc, v) -> + Int (fl loc, v) + | String (loc, v) -> + String (fl loc, v) + | Bytes (loc, v) -> + Bytes (fl loc, v) + | Seq (loc, seq) -> + Seq (fl loc, List.map (map_node fl fp) seq) + | Prim (loc, name, seq, annots) -> + Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots) + +type semantics = V0 | V1 + +let internal_canonical_encoding ~semantics ~variant prim_encoding = + let open Data_encoding in + let int_encoding = + obj1 (req "int" z) in + let string_encoding = + obj1 (req "string" string) in + let bytes_encoding = + obj1 (req "bytes" bytes) in + let int_encoding tag = + case tag int_encoding + ~title:"Int" + (function Int (_, v) -> Some v | _ -> None) + (fun v -> Int (0, v)) in + let string_encoding tag = + case tag string_encoding + ~title:"String" + (function String (_, v) -> Some v | _ -> None) + (fun v -> String (0, v)) in + let bytes_encoding tag = + case tag bytes_encoding + ~title:"Bytes" + (function Bytes (_, v) -> Some v | _ -> None) + (fun v -> Bytes (0, v)) in + let seq_encoding tag expr_encoding = + case tag (list expr_encoding) + ~title:"Sequence" + (function Seq (_, v) -> Some v | _ -> None) + (fun args -> Seq (0, args)) in + let annots_encoding = + let split s = + if s = "" && semantics <> V0 then [] + else + let annots = String.split_on_char ' ' s in + List.iter (fun a -> + if String.length a > 255 then failwith "Oversized annotation" + ) annots; + if String.concat " " annots <> s then + failwith "Invalid annotation string, \ + must be a sequence of valid annotations with spaces" ; + annots in + splitted + ~json:(list (Bounded.string 255)) + ~binary:(conv (String.concat " ") split string) in + let application_encoding tag expr_encoding = + case tag + ~title:"Generic prim (any number of args with or without annot)" + (obj3 (req "prim" prim_encoding) + (dft "args" (list expr_encoding) []) + (dft "annots" annots_encoding [])) + (function Prim (_, prim, args, annots) -> Some (prim, args, annots) + | _ -> None) + (fun (prim, args, annots) -> Prim (0, prim, args, annots)) in + let node_encoding = mu ("micheline." ^ variant ^ ".expression") (fun expr_encoding -> + splitted + ~json:(union ~tag_size:`Uint8 + [ int_encoding Json_only; + string_encoding Json_only ; + bytes_encoding Json_only ; + seq_encoding Json_only expr_encoding ; + application_encoding Json_only expr_encoding ]) + ~binary:(union ~tag_size:`Uint8 + [ int_encoding (Tag 0) ; + string_encoding (Tag 1) ; + seq_encoding (Tag 2) expr_encoding ; + (* No args, no annot *) + case (Tag 3) + ~title:"Prim (no args, annot)" + (obj1 (req "prim" prim_encoding)) + (function Prim (_, v, [], []) -> Some v + | _ -> None) + (fun v -> Prim (0, v, [], [])) ; + (* No args, with annots *) + case (Tag 4) + ~title:"Prim (no args + annot)" + (obj2 (req "prim" prim_encoding) + (req "annots" annots_encoding)) + (function + | Prim (_, v, [], annots) -> Some (v, annots) + | _ -> None) + (function (prim, annots) -> Prim (0, prim, [], annots)) ; + (* Single arg, no annot *) + case (Tag 5) + ~title:"Prim (1 arg, no annot)" + (obj2 (req "prim" prim_encoding) + (req "arg" expr_encoding)) + (function + | Prim (_, v, [ arg ], []) -> Some (v, arg) + | _ -> None) + (function (prim, arg) -> Prim (0, prim, [ arg ], [])) ; + (* Single arg, with annot *) + case (Tag 6) + ~title:"Prim (1 arg + annot)" + (obj3 (req "prim" prim_encoding) + (req "arg" expr_encoding) + (req "annots" annots_encoding)) + (function + | Prim (_, prim, [ arg ], annots) -> Some (prim, arg, annots) + | _ -> None) + (fun (prim, arg, annots) -> Prim (0, prim, [ arg ], annots)) ; + (* Two args, no annot *) + case (Tag 7) + ~title:"Prim (2 args, no annot)" + (obj3 (req "prim" prim_encoding) + (req "arg1" expr_encoding) + (req "arg2" expr_encoding)) + (function + | Prim (_, prim, [ arg1 ; arg2 ], []) -> Some (prim, arg1, arg2) + | _ -> None) + (fun (prim, arg1, arg2) -> Prim (0, prim, [ arg1 ; arg2 ], [])) ; + (* Two args, with annots *) + case (Tag 8) + ~title:"Prim (2 args + annot)" + (obj4 (req "prim" prim_encoding) + (req "arg1" expr_encoding) + (req "arg2" expr_encoding) + (req "annots" annots_encoding)) + (function + | Prim (_, prim, [ arg1 ; arg2 ], annots) -> Some (prim, arg1, arg2, annots) + | _ -> None) + (fun (prim, arg1, arg2, annots) -> Prim (0, prim, [ arg1 ; arg2 ], annots)) ; + (* General case *) + application_encoding (Tag 9) expr_encoding ; + bytes_encoding (Tag 10) ])) + in + conv + (function Canonical node -> node) + (fun node -> strip_locations node) + node_encoding + +let canonical_encoding ~variant prim_encoding = + internal_canonical_encoding ~semantics:V1 ~variant prim_encoding +let canonical_encoding_v1 ~variant prim_encoding = + internal_canonical_encoding ~semantics:V1 ~variant prim_encoding +let canonical_encoding_v0 ~variant prim_encoding = + internal_canonical_encoding ~semantics:V0 ~variant prim_encoding + +let table_encoding ~variant location_encoding prim_encoding = + let open Data_encoding in + conv + (fun node -> + let canon, assoc = extract_locations node in + let _, table = List.split assoc in + (canon, table)) + (fun (canon, table) -> + let table = Array.of_list table in + inject_locations (fun i -> table.(i)) canon) + (obj2 + (req "expression" (canonical_encoding ~variant prim_encoding)) + (req "locations" (list location_encoding))) + +let erased_encoding ~variant default_location prim_encoding = + let open Data_encoding in + conv + (fun node -> strip_locations node) + (fun canon -> inject_locations (fun _ -> default_location) canon) + (canonical_encoding ~variant prim_encoding) diff --git a/src/lib_micheline/micheline_main.mli b/src/lib_micheline/micheline_main.mli new file mode 100644 index 000000000..49cb40c56 --- /dev/null +++ b/src/lib_micheline/micheline_main.mli @@ -0,0 +1,104 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +type annot = string list + +(** The abstract syntax tree of Micheline expressions. The first + parameter is used to contain locations, but can also embed custom + data. The second parameter is the type of primitive names. *) +type ('l, 'p) node = + | Int of 'l * Z.t + | String of 'l * string + | Bytes of 'l * MBytes.t + | Prim of 'l * 'p * ('l, 'p) node list * annot + | Seq of 'l * ('l, 'p) node list + +(** Encoding for expressions, as their {!canonical} encoding. + Locations are stored in a side table. + See {!canonical_encoding} for the [variant] parameter. *) +val table_encoding : variant:string -> + 'l Data_encoding.encoding -> 'p Data_encoding.encoding -> + ('l, 'p) node Data_encoding.encoding + +(** Encoding for expressions, as their {!canonical} encoding. + Locations are erased when serialized, and restored to a provided + default value when deserialized. + See {!canonical_encoding} for the [variant] parameter. *) +val erased_encoding : variant:string -> + 'l -> 'p Data_encoding.encoding -> ('l, 'p) node Data_encoding.encoding + +(** Extract the location of the node. *) +val location : ('l, 'p) node -> 'l + +(** Extract the annotations of the node. *) +val annotations : ('l, 'p) node -> string list + +(** Expression form using canonical integer numbering as + locations. The root has number zero, and each node adds one in the + order of infix traversal. To be used when locations are not + important, or when one wants to attach properties to nodes in an + expression without rewriting it (using an indirection table with + canonical locations as keys). *) +type 'p canonical + +(** Canonical integer locations that appear inside {!canonical} expressions. *) +type canonical_location = int + +(** Encoding for canonical integer locations. *) +val canonical_location_encoding : canonical_location Data_encoding.encoding + +(** Encoding for expressions in canonical form. The first parameter + is a name used to produce named definitions in the schemas. Make + sure to use different names if two expression variants with + different primitive encodings are used in the same schema. *) +val canonical_encoding : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding + +(** Old version of {!canonical_encoding} for retrocompatibility. + Do not use in new code. *) +val canonical_encoding_v0 : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding + +(** Alias for {!canonical_encoding}. *) +val canonical_encoding_v1 : variant:string -> 'l Data_encoding.encoding -> 'l canonical Data_encoding.encoding + +(** Compute the canonical form of an expression. + Drops the concrete locations completely. *) +val strip_locations : (_, 'p) node -> 'p canonical + +(** Give the root node of an expression in canonical form. *) +val root : 'p canonical -> (canonical_location, 'p) node + +(** Compute the canonical form of an expression. + Saves the concrete locations in an association list. *) +val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list + +(** Transforms an expression in canonical form into a polymorphic one. + Takes a mapping function to inject the concrete locations. *) +val inject_locations : (canonical_location -> 'l) -> 'p canonical -> ('l, 'p) node + +(** Copies the tree, updating its primitives. *) +val map : ('a -> 'b) -> 'a canonical -> 'b canonical + +(** Copies the tree, updating its primitives and locations. *) +val map_node : ('la -> 'lb) -> ('pa -> 'pb) -> ('la, 'pa) node -> ('lb, 'pb) node diff --git a/src/lib_micheline/michelson_primitives.ml b/src/lib_micheline/michelson_primitives.ml new file mode 100644 index 000000000..4f0b35bd3 --- /dev/null +++ b/src/lib_micheline/michelson_primitives.ml @@ -0,0 +1,563 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Micheline_main + +type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOP + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + +let valid_case name = + let is_lower = function '_' | 'a'..'z' -> true | _ -> false in + let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in + let rec for_all a b f = + Compare.Int.(a > b) || f a && for_all (a + 1) b f in + let len = String.length name in + Compare.Int.(len <> 0) + && + Compare.Char.(String.get name 0 <> '_') + && + ((is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_upper (String.get name i))) + || + (is_upper (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i))) + || + (is_lower (String.get name 0) + && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))) + +let string_of_prim = function + | K_parameter -> "parameter" + | K_storage -> "storage" + | K_code -> "code" + | D_False -> "False" + | D_Elt -> "Elt" + | D_Left -> "Left" + | D_None -> "None" + | D_Pair -> "Pair" + | D_Right -> "Right" + | D_Some -> "Some" + | D_True -> "True" + | D_Unit -> "Unit" + | I_PACK -> "PACK" + | I_UNPACK -> "UNPACK" + | I_BLAKE2B -> "BLAKE2B" + | I_SHA256 -> "SHA256" + | I_SHA512 -> "SHA512" + | I_ABS -> "ABS" + | I_ADD -> "ADD" + | I_AMOUNT -> "AMOUNT" + | I_AND -> "AND" + | I_BALANCE -> "BALANCE" + | I_CAR -> "CAR" + | I_CDR -> "CDR" + | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" + | I_COMPARE -> "COMPARE" + | I_CONCAT -> "CONCAT" + | I_CONS -> "CONS" + | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" + | I_CREATE_CONTRACT -> "CREATE_CONTRACT" + | I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT" + | I_DIP -> "DIP" + | I_DROP -> "DROP" + | I_DUP -> "DUP" + | I_EDIV -> "EDIV" + | I_EMPTY_MAP -> "EMPTY_MAP" + | I_EMPTY_SET -> "EMPTY_SET" + | I_EQ -> "EQ" + | I_EXEC -> "EXEC" + | I_FAILWITH -> "FAILWITH" + | I_GE -> "GE" + | I_GET -> "GET" + | I_GT -> "GT" + | I_HASH_KEY -> "HASH_KEY" + | I_IF -> "IF" + | I_IF_CONS -> "IF_CONS" + | I_IF_LEFT -> "IF_LEFT" + | I_IF_NONE -> "IF_NONE" + | I_INT -> "INT" + | I_LAMBDA -> "LAMBDA" + | I_LE -> "LE" + | I_LEFT -> "LEFT" + | I_LOOP -> "LOOP" + | I_LSL -> "LSL" + | I_LSR -> "LSR" + | I_LT -> "LT" + | I_MAP -> "MAP" + | I_MEM -> "MEM" + | I_MUL -> "MUL" + | I_NEG -> "NEG" + | I_NEQ -> "NEQ" + | I_NIL -> "NIL" + | I_NONE -> "NONE" + | I_NOP -> "NOP" + | I_NOT -> "NOT" + | I_NOW -> "NOW" + | I_OR -> "OR" + | I_PAIR -> "PAIR" + | I_PUSH -> "PUSH" + | I_RIGHT -> "RIGHT" + | I_SIZE -> "SIZE" + | I_SOME -> "SOME" + | I_SOURCE -> "SOURCE" + | I_SENDER -> "SENDER" + | I_SELF -> "SELF" + | I_SLICE -> "SLICE" + | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" + | I_SUB -> "SUB" + | I_SWAP -> "SWAP" + | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" + | I_SET_DELEGATE -> "SET_DELEGATE" + | I_UNIT -> "UNIT" + | I_UPDATE -> "UPDATE" + | I_XOR -> "XOR" + | I_ITER -> "ITER" + | I_LOOP_LEFT -> "LOOP_LEFT" + | I_ADDRESS -> "ADDRESS" + | I_CONTRACT -> "CONTRACT" + | I_ISNAT -> "ISNAT" + | I_CAST -> "CAST" + | I_RENAME -> "RENAME" + | T_bool -> "bool" + | T_contract -> "contract" + | T_int -> "int" + | T_key -> "key" + | T_key_hash -> "key_hash" + | T_lambda -> "lambda" + | T_list -> "list" + | T_map -> "map" + | T_big_map -> "big_map" + | T_nat -> "nat" + | T_option -> "option" + | T_or -> "or" + | T_pair -> "pair" + | T_set -> "set" + | T_signature -> "signature" + | T_string -> "string" + | T_bytes -> "bytes" + | T_mutez -> "mutez" + | T_timestamp -> "timestamp" + | T_unit -> "unit" + | T_operation -> "operation" + | T_address -> "address" + +type failure = + Unknown_primitive_name of string + | Invalid_case of string + | Invalid_primitive_name of string Micheline_main.canonical * Micheline_main.canonical_location + +let prim_of_string : string -> (prim , failure) result = function + | "parameter" -> Ok K_parameter + | "storage" -> Ok K_storage + | "code" -> Ok K_code + | "False" -> Ok D_False + | "Elt" -> Ok D_Elt + | "Left" -> Ok D_Left + | "None" -> Ok D_None + | "Pair" -> Ok D_Pair + | "Right" -> Ok D_Right + | "Some" -> Ok D_Some + | "True" -> Ok D_True + | "Unit" -> Ok D_Unit + | "PACK" -> Ok I_PACK + | "UNPACK" -> Ok I_UNPACK + | "BLAKE2B" -> Ok I_BLAKE2B + | "SHA256" -> Ok I_SHA256 + | "SHA512" -> Ok I_SHA512 + | "ABS" -> Ok I_ABS + | "ADD" -> Ok I_ADD + | "AMOUNT" -> Ok I_AMOUNT + | "AND" -> Ok I_AND + | "BALANCE" -> Ok I_BALANCE + | "CAR" -> Ok I_CAR + | "CDR" -> Ok I_CDR + | "CHECK_SIGNATURE" -> Ok I_CHECK_SIGNATURE + | "COMPARE" -> Ok I_COMPARE + | "CONCAT" -> Ok I_CONCAT + | "CONS" -> Ok I_CONS + | "CREATE_ACCOUNT" -> Ok I_CREATE_ACCOUNT + | "CREATE_CONTRACT" -> Ok I_CREATE_CONTRACT + | "IMPLICIT_ACCOUNT" -> Ok I_IMPLICIT_ACCOUNT + | "DIP" -> Ok I_DIP + | "DROP" -> Ok I_DROP + | "DUP" -> Ok I_DUP + | "EDIV" -> Ok I_EDIV + | "EMPTY_MAP" -> Ok I_EMPTY_MAP + | "EMPTY_SET" -> Ok I_EMPTY_SET + | "EQ" -> Ok I_EQ + | "EXEC" -> Ok I_EXEC + | "FAILWITH" -> Ok I_FAILWITH + | "GE" -> Ok I_GE + | "GET" -> Ok I_GET + | "GT" -> Ok I_GT + | "HASH_KEY" -> Ok I_HASH_KEY + | "IF" -> Ok I_IF + | "IF_CONS" -> Ok I_IF_CONS + | "IF_LEFT" -> Ok I_IF_LEFT + | "IF_NONE" -> Ok I_IF_NONE + | "INT" -> Ok I_INT + | "LAMBDA" -> Ok I_LAMBDA + | "LE" -> Ok I_LE + | "LEFT" -> Ok I_LEFT + | "LOOP" -> Ok I_LOOP + | "LSL" -> Ok I_LSL + | "LSR" -> Ok I_LSR + | "LT" -> Ok I_LT + | "MAP" -> Ok I_MAP + | "MEM" -> Ok I_MEM + | "MUL" -> Ok I_MUL + | "NEG" -> Ok I_NEG + | "NEQ" -> Ok I_NEQ + | "NIL" -> Ok I_NIL + | "NONE" -> Ok I_NONE + | "NOP" -> Ok I_NOP + | "NOT" -> Ok I_NOT + | "NOW" -> Ok I_NOW + | "OR" -> Ok I_OR + | "PAIR" -> Ok I_PAIR + | "PUSH" -> Ok I_PUSH + | "RIGHT" -> Ok I_RIGHT + | "SIZE" -> Ok I_SIZE + | "SOME" -> Ok I_SOME + | "SOURCE" -> Ok I_SOURCE + | "SENDER" -> Ok I_SENDER + | "SELF" -> Ok I_SELF + | "SLICE" -> Ok I_SLICE + | "STEPS_TO_QUOTA" -> Ok I_STEPS_TO_QUOTA + | "SUB" -> Ok I_SUB + | "SWAP" -> Ok I_SWAP + | "TRANSFER_TOKENS" -> Ok I_TRANSFER_TOKENS + | "SET_DELEGATE" -> Ok I_SET_DELEGATE + | "UNIT" -> Ok I_UNIT + | "UPDATE" -> Ok I_UPDATE + | "XOR" -> Ok I_XOR + | "ITER" -> Ok I_ITER + | "LOOP_LEFT" -> Ok I_LOOP_LEFT + | "ADDRESS" -> Ok I_ADDRESS + | "CONTRACT" -> Ok I_CONTRACT + | "ISNAT" -> Ok I_ISNAT + | "CAST" -> Ok I_CAST + | "RENAME" -> Ok I_RENAME + | "bool" -> Ok T_bool + | "contract" -> Ok T_contract + | "int" -> Ok T_int + | "key" -> Ok T_key + | "key_hash" -> Ok T_key_hash + | "lambda" -> Ok T_lambda + | "list" -> Ok T_list + | "map" -> Ok T_map + | "big_map" -> Ok T_big_map + | "nat" -> Ok T_nat + | "option" -> Ok T_option + | "or" -> Ok T_or + | "pair" -> Ok T_pair + | "set" -> Ok T_set + | "signature" -> Ok T_signature + | "string" -> Ok T_string + | "bytes" -> Ok T_bytes + | "mutez" -> Ok T_mutez + | "timestamp" -> Ok T_timestamp + | "unit" -> Ok T_unit + | "operation" -> Ok T_operation + | "address" -> Ok T_address + | n -> + if valid_case n then + Error (Unknown_primitive_name n) + else + Error (Invalid_case n) + +let (>>?) x f : (_ , failure) result = match x with + | Ok x -> f x + | Error _ as err -> err + +let prims_of_strings : string canonical -> (prim Micheline_main.canonical , failure) result = fun expr -> + let rec convert : (canonical_location , string) node -> ((canonical_location , prim) node , failure) result = function + | Int _ | String _ | Bytes _ as expr -> Ok expr + | Seq (_, args) -> ( + let aux : ((canonical_location , prim) node list , failure) result -> (canonical_location , string) node -> ((_ , prim) node list , failure) result = + fun acc arg -> + acc >>? fun acc' -> + convert arg >>? fun arg' -> + Ok (arg' :: acc') + in + (List.fold_left aux (Ok []) args) >>? fun args' -> + Ok (Seq (0, List.rev args')) + ) + | Prim (_, prim, args, annot) -> ( + prim_of_string prim >>? fun prim' -> + let aux : (_ list , failure) result -> _ -> (_ list , failure) result = fun acc arg -> + acc >>? fun args -> + convert arg >>? fun arg -> + Ok (arg :: args) + in + List.fold_left aux (Ok []) args >>? fun args' -> + Ok (Prim (0, prim', List.rev args', annot)) + ) + in + convert (root expr) >>? fun expr -> + Ok (strip_locations expr) + +let strings_of_prims expr = + let rec convert = function + | Int _ | String _ | Bytes _ as expr -> expr + | Prim (_, prim, args, annot) -> + let prim = string_of_prim prim in + let args = List.map convert args in + Prim (0, prim, args, annot) + | Seq (_, args) -> + let args = List.map convert args in + Seq (0, args) in + strip_locations (convert (root expr)) + +let prim_encoding = + let open Data_encoding in + def "michelson.v1.primitives" @@ + string_enum [ + ("parameter", K_parameter) ; + ("storage", K_storage) ; + ("code", K_code) ; + ("False", D_False) ; + ("Elt", D_Elt) ; + ("Left", D_Left) ; + ("None", D_None) ; + ("Pair", D_Pair) ; + ("Right", D_Right) ; + ("Some", D_Some) ; + ("True", D_True) ; + ("Unit", D_Unit) ; + ("PACK", I_PACK) ; + ("UNPACK", I_UNPACK) ; + ("BLAKE2B", I_BLAKE2B) ; + ("SHA256", I_SHA256) ; + ("SHA512", I_SHA512) ; + ("ABS", I_ABS) ; + ("ADD", I_ADD) ; + ("AMOUNT", I_AMOUNT) ; + ("AND", I_AND) ; + ("BALANCE", I_BALANCE) ; + ("CAR", I_CAR) ; + ("CDR", I_CDR) ; + ("CHECK_SIGNATURE", I_CHECK_SIGNATURE) ; + ("COMPARE", I_COMPARE) ; + ("CONCAT", I_CONCAT) ; + ("CONS", I_CONS) ; + ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; + ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; + ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; + ("DIP", I_DIP) ; + ("DROP", I_DROP) ; + ("DUP", I_DUP) ; + ("EDIV", I_EDIV) ; + ("EMPTY_MAP", I_EMPTY_MAP) ; + ("EMPTY_SET", I_EMPTY_SET) ; + ("EQ", I_EQ) ; + ("EXEC", I_EXEC) ; + ("FAILWITH", I_FAILWITH) ; + ("GE", I_GE) ; + ("GET", I_GET) ; + ("GT", I_GT) ; + ("HASH_KEY", I_HASH_KEY) ; + ("IF", I_IF) ; + ("IF_CONS", I_IF_CONS) ; + ("IF_LEFT", I_IF_LEFT) ; + ("IF_NONE", I_IF_NONE) ; + ("INT", I_INT) ; + ("LAMBDA", I_LAMBDA) ; + ("LE", I_LE) ; + ("LEFT", I_LEFT) ; + ("LOOP", I_LOOP) ; + ("LSL", I_LSL) ; + ("LSR", I_LSR) ; + ("LT", I_LT) ; + ("MAP", I_MAP) ; + ("MEM", I_MEM) ; + ("MUL", I_MUL) ; + ("NEG", I_NEG) ; + ("NEQ", I_NEQ) ; + ("NIL", I_NIL) ; + ("NONE", I_NONE) ; + ("NOT", I_NOT) ; + ("NOW", I_NOW) ; + ("OR", I_OR) ; + ("PAIR", I_PAIR) ; + ("PUSH", I_PUSH) ; + ("RIGHT", I_RIGHT) ; + ("SIZE", I_SIZE) ; + ("SOME", I_SOME) ; + ("SOURCE", I_SOURCE) ; + ("SENDER", I_SENDER) ; + ("SELF", I_SELF) ; + ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ; + ("SUB", I_SUB) ; + ("SWAP", I_SWAP) ; + ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; + ("SET_DELEGATE", I_SET_DELEGATE) ; + ("UNIT", I_UNIT) ; + ("UPDATE", I_UPDATE) ; + ("XOR", I_XOR) ; + ("ITER", I_ITER) ; + ("LOOP_LEFT", I_LOOP_LEFT) ; + ("ADDRESS", I_ADDRESS) ; + ("CONTRACT", I_CONTRACT) ; + ("ISNAT", I_ISNAT) ; + ("CAST", I_CAST) ; + ("RENAME", I_RENAME) ; + ("bool", T_bool) ; + ("contract", T_contract) ; + ("int", T_int) ; + ("key", T_key) ; + ("key_hash", T_key_hash) ; + ("lambda", T_lambda) ; + ("list", T_list) ; + ("map", T_map) ; + ("big_map", T_big_map) ; + ("nat", T_nat) ; + ("option", T_option) ; + ("or", T_or) ; + ("pair", T_pair) ; + ("set", T_set) ; + ("signature", T_signature) ; + ("string", T_string) ; + ("bytes", T_bytes) ; + ("mutez", T_mutez) ; + ("timestamp", T_timestamp) ; + ("unit", T_unit) ; + ("operation", T_operation) ; + ("address", T_address) ; + (* Alpha_002 addition *) + ("SLICE", I_SLICE) ; + ] + diff --git a/src/lib_protocol_environment/sigs/v1/micheline.mli b/src/lib_protocol_environment/sigs/v1/micheline.mli index ba2609374..26885894f 100644 --- a/src/lib_protocol_environment/sigs/v1/micheline.mli +++ b/src/lib_protocol_environment/sigs/v1/micheline.mli @@ -49,3 +49,136 @@ val annotations : ('l, 'p) node -> string list val strip_locations : (_, 'p) node -> 'p canonical val extract_locations : ('l, 'p) node -> 'p canonical * (canonical_location * 'l) list val inject_locations : (canonical_location -> 'l) -> 'p canonical -> ('l, 'p) node + +module Michelson_primitives : sig + type prim = + | K_parameter + | K_storage + | K_code + | D_False + | D_Elt + | D_Left + | D_None + | D_Pair + | D_Right + | D_Some + | D_True + | D_Unit + | I_PACK + | I_UNPACK + | I_BLAKE2B + | I_SHA256 + | I_SHA512 + | I_ABS + | I_ADD + | I_AMOUNT + | I_AND + | I_BALANCE + | I_CAR + | I_CDR + | I_CHECK_SIGNATURE + | I_COMPARE + | I_CONCAT + | I_CONS + | I_CREATE_ACCOUNT + | I_CREATE_CONTRACT + | I_IMPLICIT_ACCOUNT + | I_DIP + | I_DROP + | I_DUP + | I_EDIV + | I_EMPTY_MAP + | I_EMPTY_SET + | I_EQ + | I_EXEC + | I_FAILWITH + | I_GE + | I_GET + | I_GT + | I_HASH_KEY + | I_IF + | I_IF_CONS + | I_IF_LEFT + | I_IF_NONE + | I_INT + | I_LAMBDA + | I_LE + | I_LEFT + | I_LOOP + | I_LSL + | I_LSR + | I_LT + | I_MAP + | I_MEM + | I_MUL + | I_NEG + | I_NEQ + | I_NIL + | I_NONE + | I_NOP + | I_NOT + | I_NOW + | I_OR + | I_PAIR + | I_PUSH + | I_RIGHT + | I_SIZE + | I_SOME + | I_SOURCE + | I_SENDER + | I_SELF + | I_SLICE + | I_STEPS_TO_QUOTA + | I_SUB + | I_SWAP + | I_TRANSFER_TOKENS + | I_SET_DELEGATE + | I_UNIT + | I_UPDATE + | I_XOR + | I_ITER + | I_LOOP_LEFT + | I_ADDRESS + | I_CONTRACT + | I_ISNAT + | I_CAST + | I_RENAME + | T_bool + | T_contract + | T_int + | T_key + | T_key_hash + | T_lambda + | T_list + | T_map + | T_big_map + | T_nat + | T_option + | T_or + | T_pair + | T_set + | T_signature + | T_string + | T_bytes + | T_mutez + | T_timestamp + | T_unit + | T_operation + | T_address + + val prim_encoding : prim Data_encoding.encoding + + val string_of_prim : prim -> string + + type failure = + Unknown_primitive_name of string + | Invalid_case of string + | Invalid_primitive_name of string canonical * canonical_location + + + val prim_of_string : string -> (prim , failure) result + + val prims_of_strings : string canonical -> (prim canonical , failure) result + + val strings_of_prims : prim canonical -> string canonical +end diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 54c85d813..343ff9f34 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -176,6 +176,7 @@ module Make (Context : CONTEXT) = struct and type Signature.t = Signature.t and type Signature.watermark = Signature.watermark and type 'a Micheline.canonical = 'a Micheline.canonical + and type Micheline.Michelson_primitives.prim = Micheline.Michelson_primitives.prim and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type Z.t = Z.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index 0396faf13..3bd0465e8 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -155,6 +155,7 @@ module Make (Context : CONTEXT) : sig and type 'a Micheline.canonical = 'a Micheline.canonical and type Z.t = Z.t and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node + and type Micheline.Michelson_primitives.prim = Micheline.Michelson_primitives.prim and type Data_encoding.json_schema = Data_encoding.json_schema and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t and type RPC_service.meth = RPC_service.meth diff --git a/src/lib_utils/.gitignore b/src/lib_utils/.gitignore deleted file mode 100644 index 574db7233..000000000 --- a/src/lib_utils/.gitignore +++ /dev/null @@ -1,7 +0,0 @@ -*.install -*.merlin -#* -*_opam -*~ -_build/* -*/_build/* \ No newline at end of file diff --git a/src/lib_utils/PP.ml b/src/lib_utils/PP.ml deleted file mode 100644 index 70f6410d1..000000000 --- a/src/lib_utils/PP.ml +++ /dev/null @@ -1,59 +0,0 @@ -open Format -let string : formatter -> string -> unit = fun ppf s -> fprintf ppf "%s" s -let tag tag : formatter -> unit -> unit = fun ppf () -> fprintf ppf tag -let bool ppf b = fprintf ppf "%b" b -let pair f g ppf (a , b) = fprintf ppf "%a , %a" f a g b -let new_line : formatter -> unit -> unit = tag "@;" -let rec new_lines n ppf () = - match n with - | 0 -> new_line ppf () - | n -> new_line ppf () ; new_lines (n-1) ppf () -let const const : formatter -> unit -> unit = fun ppf () -> fprintf ppf "%s" const -let comment : formatter -> string -> unit = fun ppf s -> fprintf ppf "(* %s *)" s -let list_sep value separator = pp_print_list ~pp_sep:separator value -let list value = pp_print_list ~pp_sep:(tag "") value -let ne_list_sep value separator ppf (hd, tl) = - value ppf hd ; - separator ppf () ; - pp_print_list ~pp_sep:separator value ppf tl - -let prepend s f ppf a = - fprintf ppf "%s%a" s f a - -let option = fun f ppf opt -> - match opt with - | Some x -> fprintf ppf "Some(%a)" f x - | None -> fprintf ppf "None" - -let lr = fun ppf lr -> - match lr with - | `Left -> fprintf ppf "left" - | `Right -> fprintf ppf "right" - -let int = fun ppf n -> fprintf ppf "%d" n - -let map = fun f pp ppf x -> - pp ppf (f x) - -let pair_sep value sep ppf (a, b) = fprintf ppf "%a %s %a" value a sep value b -let smap_sep value sep ppf m = - let module SMap = X_map.String in - let lst = SMap.to_kv_list m in - let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in - fprintf ppf "%a" (list_sep new_pp sep) lst - -(* TODO: remove all uses. this is bad. *) -let printer : ('a -> unit) -> _ -> 'a -> unit = fun f ppf x -> - let oldstdout = Unix.dup Unix.stdout in - let name = "/tmp/wtf-" ^ (string_of_int @@ Random.bits ()) in - let newstdout = open_out name in - Unix.dup2 (Unix.descr_of_out_channel newstdout) Unix.stdout; - f x; - flush stdout; - Unix.dup2 oldstdout Unix.stdout; - let ic = open_in name in - let n = in_channel_length ic in - let s = Bytes.create n in - really_input ic s 0 n; - close_in ic; - fprintf ppf "%s" (Bytes.to_string s) diff --git a/src/lib_utils/cast.ml b/src/lib_utils/cast.ml deleted file mode 100644 index 2c02c59b6..000000000 --- a/src/lib_utils/cast.ml +++ /dev/null @@ -1,190 +0,0 @@ -module Error_monad = X_error_monad -open Tezos_micheline - -let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment () - -open Memory_proto_alpha -open Alpha_context - -exception Expr_from_string -let expr_of_string str = - let (ast, errs) = Michelson_parser.V1.parse_expression ~check:false str in - (match errs with - | [] -> () - | lst -> ( - Format.printf "expr_from_string: %a\n" Error_monad.pp_print_error lst; - raise Expr_from_string - )); - ast.expanded - -let tl_of_string str = - let (ast, errs) = Michelson_parser.V1.parse_toplevel ~check:false str in - (match errs with - | [] -> () - | lst -> ( - Format.printf "expr_from_string: %a\n" Error_monad.pp_print_error lst; - raise Expr_from_string - )); - ast.expanded - -let lexpr_of_string str = - Script.lazy_expr @@ expr_of_string str - -let ltl_of_string str = - Script.lazy_expr @@ tl_of_string str - -let node_of_string str = - Micheline.root @@ expr_of_string str - -let node_to_string (node:_ Micheline.node) = - let stripped = Micheline.strip_locations node in - let print_node = Micheline_printer.printable Michelson_v1_primitives.string_of_prim stripped in - Micheline_printer.print_expr Format.str_formatter print_node ; - Format.flush_str_formatter () - -open Script_ir_translator - -let rec mapper (Ex_typed_value (ty, a)) = - let open Alpha_environment.Error_monad in - let open Script_typed_ir in - let open Micheline in - match ty, a with - | Big_map_t (kt, vt, Some (`Type_annot "toto")), map -> - let kt = ty_of_comparable_ty kt in - fold_left_s - (fun l (k, v) -> - match v with - | None -> return l - | Some v -> ( - let key = data_to_node (Ex_typed_value (kt, k)) in - let value = data_to_node (Ex_typed_value (vt, v)) in - return (Prim (-1, Michelson_v1_primitives.D_Elt, [ key ; value ], []) :: l)) - ) - [] - (map_fold (fun k v acc -> (k, v) :: acc) map.diff []) >>=? fun items -> - return (Some (Micheline.Seq (-1, String (-1, "...") :: items))) - | _ -> return None - -and data_to_node (Ex_typed_value (ty, data)) = - let tc = env.tezos_context in - let node_lwt = Script_ir_translator.unparse_data tc ~mapper Readable ty data in - let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in - node - -let data_to_string ty data = - let node = data_to_node (Ex_typed_value (ty, data)) in - node_to_string node - -open Script_typed_ir -open Script_interpreter -type ex_typed_stack = - Ex_typed_stack : ('a stack_ty * 'a stack) -> ex_typed_stack - -let stack_to_string stack_ty stack = - let rec aux acc fst (Ex_typed_stack(stack_ty,stack)) = - match (stack_ty, stack) with - | Item_t (hd_ty, tl_ty, _), Item (hd, tl) -> ( - let separator = if not fst then " ; " else "" in - let str = data_to_string hd_ty hd in - let acc = acc ^ separator ^ str in - let new_value = aux acc false (Ex_typed_stack (tl_ty, tl)) in - new_value - ) - | _ -> acc in - aux "" true @@ Ex_typed_stack(stack_ty, stack) - -let ty_to_node ty = - let (node, _) = Error_monad.force_lwt_alpha ~msg:"ty to node" @@ Script_ir_translator.unparse_ty env.tezos_context ty in - node - -type ex_descr = - Ex_descr : (_, _) Script_typed_ir.descr -> ex_descr - -let descr_to_node x = - let open Alpha_context.Script in - let open Micheline in - let open Script_typed_ir in - let rec f : ex_descr -> Script.node = fun descr -> - let prim ?children ?children_nodes p = - match (children, children_nodes) with - | Some children, None -> - Prim (0, p, List.map f children, []) - | Some _, Some _ -> - raise @@ Failure "descr_to_node: too many parameters" - | None, Some children_nodes -> - Prim (0, p, children_nodes, []) - | None, None -> - Prim (0, p, [], []) - in - let (Ex_descr descr) = descr in - match descr.instr with - | Dup -> prim I_DUP - | Drop -> prim I_DROP - | Swap -> prim I_SWAP - | Dip c -> prim ~children:[Ex_descr c] I_DIP - | Car -> prim I_CAR - | Cdr -> prim I_CDR - | Cons_pair -> prim I_PAIR - | Nop -> prim I_NOP - | Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b]) - | Const v -> ( - let (Item_t (ty, _, _)) = descr.aft in - prim ~children_nodes:[data_to_node (Ex_typed_value (ty, v))] I_PUSH - ) - | Failwith _ -> prim I_FAILWITH - | If (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF - | Loop c -> prim ~children:[Ex_descr c] I_LOOP - | If_left (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_LEFT - | Left -> prim I_LEFT - | Right -> prim I_RIGHT - | Loop_left c -> prim ~children:[Ex_descr c] I_LOOP_LEFT - | If_none (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_NONE - | Cons_none _ -> prim I_NONE - | Cons_some -> prim I_SOME - | Nil -> prim I_NIL - | Cons_list -> prim I_CONS - | If_cons (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_CONS - | List_iter _ -> prim I_ITER - | Compare _ -> prim I_COMPARE - | Int_nat -> prim I_INT - | Add_natnat -> prim I_ADD - | Add_natint -> prim I_ADD - | Add_intnat -> prim I_ADD - | Sub_int -> prim I_SUB - | Mul_natnat -> prim I_MUL - | Ediv_natnat -> prim I_MUL - | Map_get -> prim I_GET - | Map_update -> prim I_UPDATE - | Big_map_get -> prim I_GET - | Big_map_update -> prim I_UPDATE - | Gt -> prim I_GT - | Ge -> prim I_GE - | Pack _ -> prim I_PACK - | Unpack _ -> prim I_UNPACK - | Blake2b -> prim I_BLAKE2B - | And -> prim I_AND - | Xor -> prim I_XOR - | _ -> raise @@ Failure "descr to node" in - f @@ Ex_descr x - -let rec flatten_node = - let open Micheline in - function - | Seq (a, lst) -> ( - let aux = function - | Prim (loc, p, children, annot) -> [ Prim (loc, p, List.map flatten_node children, annot) ] - | Seq (_, lst) -> List.map flatten_node lst - | x -> [ x ] in - let seqs = List.map aux @@ List.map flatten_node lst in - Seq (a, List.concat seqs) ) - | x -> x - -let descr_to_string descr = - let node = descr_to_node descr in - let node = flatten_node node in - node_to_string node - -let n_of_int n = - match Script_int.is_nat @@ Script_int.of_int n with - | None -> raise @@ Failure "n_of_int" - | Some n -> n diff --git a/src/lib_utils/dictionary.ml b/src/lib_utils/dictionary.ml deleted file mode 100644 index 130c01af8..000000000 --- a/src/lib_utils/dictionary.ml +++ /dev/null @@ -1,53 +0,0 @@ -open Trace - -module type DICTIONARY = sig - type ('a, 'b) t - - val get_exn : ('a, 'b) t -> 'a -> 'b - val get : ('a, 'b) t -> 'a -> 'b result - - val set : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - - val del : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> ('a, 'b) t - - val to_list : ('a, 'b) t -> ('a * 'b) list -end - -module Assoc : DICTIONARY = struct - - type ('a, 'b) t = ('a * 'b) list - - let get_exn x y = List.assoc y x - - let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y - - let set ?equal lst a b = - let equal : 'a -> 'a -> bool = - X_option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - - let del ?equal lst a = - let equal : 'a -> 'a -> bool = - X_option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux acc tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - - let to_list x = x -end diff --git a/src/lib_utils/dune b/src/lib_utils/dune deleted file mode 100644 index d37d7fdf8..000000000 --- a/src/lib_utils/dune +++ /dev/null @@ -1,14 +0,0 @@ -(library - (name tezos_utils) - (public_name tezos-utils) - (libraries - tezos-stdlib-unix - tezos-crypto - tezos-data-encoding - tezos-protocol-environment - tezos-protocol-alpha - tezos-micheline - michelson-parser - yojson - ) -) diff --git a/src/lib_utils/function.ml b/src/lib_utils/function.ml deleted file mode 100644 index 57179077f..000000000 --- a/src/lib_utils/function.ml +++ /dev/null @@ -1,8 +0,0 @@ -let constant x _ = x - -let compose = fun f g x -> f (g x) -let (>|) = compose - -let compose_2 = fun f g x y -> f (g x y) -let compose_3 = fun f g x y z -> f (g x y z) -let compose_4 = fun f g a b c d -> f (g a b c d) diff --git a/src/lib_utils/init_proto_alpha.ml b/src/lib_utils/init_proto_alpha.ml deleted file mode 100644 index 30a3de657..000000000 --- a/src/lib_utils/init_proto_alpha.ml +++ /dev/null @@ -1,291 +0,0 @@ -open Memory_proto_alpha -module Signature = Tezos_base.TzPervasives.Signature -module Data_encoding = Alpha_environment.Data_encoding -module MBytes = Alpha_environment.MBytes -module Error_monad = X_error_monad -open Error_monad - - - -module Context_init = struct - - type account = { - pkh : Signature.Public_key_hash.t ; - pk : Signature.Public_key.t ; - sk : Signature.Secret_key.t ; - } - - let generate_accounts n : (account * Tez_repr.t) list = - let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in - List.map (fun _ -> - let (pkh, pk, sk) = Signature.generate_key () in - let account = { pkh ; pk ; sk } in - account, amount) - (X_list.range n) - - let make_shell - ~level ~predecessor ~timestamp ~fitness ~operations_hash = - Tezos_base.Block_header.{ - level ; - predecessor ; - timestamp ; - fitness ; - operations_hash ; - (* We don't care of the following values, only the shell validates them. *) - proto_level = 0 ; - validation_passes = 0 ; - context = Alpha_environment.Context_hash.zero ; - } - - let default_proof_of_work_nonce = - MBytes.create Alpha_context.Constants.proof_of_work_nonce_size - - let protocol_param_key = [ "protocol_parameters" ] - - let check_constants_consistency constants = - let open Constants_repr in - let open Error_monad in - let { blocks_per_cycle ; blocks_per_commitment ; - blocks_per_roll_snapshot ; _ } = constants in - Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) - (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ - less than blocks per cycle") >>=? fun () -> - Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) - (fun () -> failwith "Inconsistent constants : blocks per cycle \ - must be superior than blocks per roll snapshot") >>=? - return - - - let initial_context - constants - header - commitments - initial_accounts - security_deposit_ramp_up_cycles - no_reward_cycles - = - let open Tezos_base.TzPervasives.Error_monad in - let bootstrap_accounts = - List.map (fun ({ pk ; pkh ; _ }, amount) -> - Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount } - ) initial_accounts - in - let json = - Data_encoding.Json.construct - Parameters_repr.encoding - Parameters_repr.{ - bootstrap_accounts ; - bootstrap_contracts = [] ; - commitments ; - constants ; - security_deposit_ramp_up_cycles ; - no_reward_cycles ; - } - in - let proto_params = - Data_encoding.Binary.to_bytes_exn Data_encoding.json json - in - Tezos_protocol_environment_memory.Context.( - set empty ["version"] (MBytes.of_string "genesis") - ) >>= fun ctxt -> - Tezos_protocol_environment_memory.Context.( - set ctxt protocol_param_key proto_params - ) >>= fun ctxt -> - Main.init ctxt header - >|= Alpha_environment.wrap_error >>=? fun { context; _ } -> - return context - - let genesis - ?(preserved_cycles = Constants_repr.default.preserved_cycles) - ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) - ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) - ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) - ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) - ?(time_between_blocks = Constants_repr.default.time_between_blocks) - ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) - ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) - ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) - ?(proof_of_work_threshold = Int64.(neg one)) - ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) - ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) - ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) - ?(origination_size = Constants_repr.default.origination_size) - ?(block_security_deposit = Constants_repr.default.block_security_deposit) - ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) - ?(block_reward = Constants_repr.default.block_reward) - ?(endorsement_reward = Constants_repr.default.endorsement_reward) - ?(cost_per_byte = Constants_repr.default.cost_per_byte) - ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) - ?(commitments = []) - ?(security_deposit_ramp_up_cycles = None) - ?(no_reward_cycles = None) - (initial_accounts : (account * Tez_repr.t) list) - = - if initial_accounts = [] then - Pervasives.failwith "Must have one account with a roll to bake"; - - (* Check there is at least one roll *) - let open Tezos_base.TzPervasives.Error_monad in - begin try - let (>>?=) x y = match x with - | Ok(a) -> y a - | Error(b) -> fail @@ List.hd b in - fold_left_s (fun acc (_, amount) -> - Alpha_environment.wrap_error @@ - Tez_repr.(+?) acc amount >>?= fun acc -> - if acc >= tokens_per_roll then - raise Exit - else return acc - ) Tez_repr.zero initial_accounts >>=? fun _ -> - failwith "Insufficient tokens in initial accounts to create one roll" - with Exit -> return () - end >>=? fun () -> - - let constants : Constants_repr.parametric = { - preserved_cycles ; - blocks_per_cycle ; - blocks_per_commitment ; - blocks_per_roll_snapshot ; - blocks_per_voting_period ; - time_between_blocks ; - endorsers_per_block ; - hard_gas_limit_per_operation ; - hard_gas_limit_per_block ; - proof_of_work_threshold ; - tokens_per_roll ; - michelson_maximum_type_size ; - seed_nonce_revelation_tip ; - origination_size ; - block_security_deposit ; - endorsement_security_deposit ; - block_reward ; - endorsement_reward ; - cost_per_byte ; - hard_storage_limit_per_operation ; - } in - check_constants_consistency constants >>=? fun () -> - - let hash = - Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" - in - let shell = make_shell - ~level:0l - ~predecessor:hash - ~timestamp:Tezos_base.TzPervasives.Time.epoch - ~fitness: (Fitness_repr.from_int64 0L) - ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in - initial_context - constants - shell - commitments - initial_accounts - security_deposit_ramp_up_cycles - no_reward_cycles - >>=? fun context -> - return (context, shell, hash) - - let init - ?(slow=false) - ?preserved_cycles - ?endorsers_per_block - ?commitments - n = - let open Error_monad in - let accounts = generate_accounts n in - let contracts = List.map (fun (a, _) -> - Alpha_context.Contract.implicit_contract (a.pkh)) accounts in - begin - if slow then - genesis - ?preserved_cycles - ?endorsers_per_block - ?commitments - accounts - else - genesis - ?preserved_cycles - ~blocks_per_cycle:32l - ~blocks_per_commitment:4l - ~blocks_per_roll_snapshot:8l - ~blocks_per_voting_period:(Int32.mul 32l 8l) - ?endorsers_per_block - ?commitments - accounts - end >>=? fun ctxt -> - return (ctxt, accounts, contracts) - - let contents - ?(proof_of_work_nonce = default_proof_of_work_nonce) - ?(priority = 0) ?seed_nonce_hash () = - Alpha_context.Block_header.({ - priority ; - proof_of_work_nonce ; - seed_nonce_hash ; - }) - - - let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt = - let contents = contents ~priority () in - let protocol_data = Alpha_context.Block_header.{ - contents ; - signature = Signature.zero ; - } in - let timestamp = Alpha_environment.Time.add timestamp @@ Int64.of_int 180 in - Main.begin_construction - ~chain_id: Alpha_environment.Chain_id.zero - ~predecessor_context: ctxt - ~predecessor_timestamp: header.timestamp - ~predecessor_fitness: header.fitness - ~predecessor_level: header.level - ~predecessor:hash - ~timestamp - ~protocol_data - () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state -> - return state.ctxt - - let main n = - init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> - let timestamp = Tezos_base.Time.now () in - begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> - return (ctxt, accounts, contracts) - -end - -type identity = { - public_key_hash : Signature.public_key_hash; - public_key : Signature.public_key; - secret_key : Signature.secret_key; - implicit_contract : Alpha_context.Contract.t; - } - -type environment = { - tezos_context : Alpha_context.t ; - identities : identity list ; - } - -let init_environment () = - Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) -> - let accounts = List.map fst accounts in - let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in - let identities = - List.map (fun ((a:Context_init.account), c) -> { - public_key = a.pk ; - public_key_hash = a.pkh ; - secret_key = a.sk ; - implicit_contract = c ; - }) @@ - List.combine accounts contracts in - return {tezos_context ; identities} - -let contextualize ~msg ?environment f = - let lwt = - let environment = match environment with - | None -> init_environment () - | Some x -> return x in - environment >>=? f - in - force_ok ~msg @@ Lwt_main.run lwt - -let dummy_environment = - X_error_monad.force_lwt ~msg:"Init_proto_alpha : initing dummy environment" @@ - init_environment () diff --git a/src/lib_utils/location.ml b/src/lib_utils/location.ml deleted file mode 100644 index d8a945000..000000000 --- a/src/lib_utils/location.ml +++ /dev/null @@ -1,37 +0,0 @@ -(* type file_location = { *) -(* filename : string ; *) -(* start_line : int ; *) -(* start_column : int ; *) -(* end_line : int ; *) -(* end_column : int ; *) -(* } *) - -type virtual_location = string - -type t = - | File of Region.t (* file_location *) - | Virtual of virtual_location - -let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = - (* TODO: give correct unicode offsets (the random number is here so - that searching for wrong souce locations appearing in messages - will quickly lead here *) - File (Region.make - ~start:(Pos.make ~byte:start_pos ~point_num:(-1897000) ~point_bol:(-1897000)) - ~stop:(Pos.make ~byte:end_pos ~point_num:(-1897000) ~point_bol:(-1897000))) - -let virtual_location s = Virtual s -let dummy = virtual_location "dummy" - -type 'a wrap = { - wrap_content : 'a ; - location : t ; -} - -let wrap ~loc wrap_content = { wrap_content ; location = loc } -let unwrap { wrap_content ; _ } = wrap_content -let map f x = { x with wrap_content = f x.wrap_content } -let pp_wrap f ppf { wrap_content ; _ } = Format.fprintf ppf "%a" f wrap_content - -let lift_region : 'a Region.reg -> 'a wrap = fun x -> - wrap ~loc:(File x.region) x.value diff --git a/src/lib_utils/logger.ml b/src/lib_utils/logger.ml deleted file mode 100644 index 76f536175..000000000 --- a/src/lib_utils/logger.ml +++ /dev/null @@ -1,11 +0,0 @@ -module Stateful () : sig - val log : string -> unit - val get : unit -> string -end = struct - - let logger = ref "" - let log : string -> unit = - fun s -> logger := !logger ^ s - let get () : string = !logger - -end diff --git a/src/lib_utils/michelson-parser/dune b/src/lib_utils/michelson-parser/dune deleted file mode 100644 index 10b030335..000000000 --- a/src/lib_utils/michelson-parser/dune +++ /dev/null @@ -1,15 +0,0 @@ -(library - (name michelson_parser) - (public_name michelson-parser) - (libraries - tezos-base - tezos-memory-proto-alpha - ) - (flags (:standard -w -9-32 -safe-string - -open Tezos_base__TzPervasives - ))) - -(alias - (name runtest_indent) - (deps (glob_files *.ml*)) - (action (run bash %{libexec:tezos-stdlib:test-ocp-indent.sh} %{deps}))) diff --git a/src/lib_utils/michelson-parser/michelson-parser.opam b/src/lib_utils/michelson-parser/michelson-parser.opam deleted file mode 100644 index cbf890d09..000000000 --- a/src/lib_utils/michelson-parser/michelson-parser.opam +++ /dev/null @@ -1,21 +0,0 @@ -name: "michelson-parser" -opam-version: "2.0" -version: "1.0" -maintainer: "gabriel.alfour@gmail.com" -authors: [ "Galfour" ] -homepage: "https://gitlab.com/gabriel.alfour/tezos" -bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues" -dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git" -license: "MIT" -depends: [ - "ocamlfind" { build } - "dune" - "tezos-memory-proto-alpha" -] -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "mv" "src/lib_utils/michelson-parser/michelson-parser.install" "." ] -] -url { - src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" -} diff --git a/src/lib_utils/michelson-parser/michelson_v1_macros.ml b/src/lib_utils/michelson-parser/michelson_v1_macros.ml deleted file mode 100644 index 1fc947f5b..000000000 --- a/src/lib_utils/michelson-parser/michelson_v1_macros.ml +++ /dev/null @@ -1,1176 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Tezos_micheline -open Micheline - -module IntMap = Map.Make (Compare.Int) - -type 'l node = ('l, string) Micheline.node - -type error += Unexpected_macro_annotation of string -type error += Sequence_expected of string -type error += Invalid_arity of string * int * int - -let rec check_letters str i j f = - i > j || f (String.get str i) && check_letters str (i + 1) j f - -let expand_caddadr original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'C' - && String.get str (len - 1) = 'R' - && check_letters str 1 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - let rec parse i annot acc = - if i = 0 then - Seq (loc, acc) - else - let annot = if i = len - 2 then annot else [] in - match String.get str i with - | 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc) - | 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc) - | _ -> assert false in - ok (Some (parse (len - 2) annot [])) - else - ok None - | _ -> ok None - -let extract_first_annot annot char = - let rec extract_first_annot others = function - | [] -> None, List.rev others - | a :: rest -> - try - if a.[0] = char - then Some a, List.rev_append others rest - else extract_first_annot (a :: others) rest - with Invalid_argument _ -> extract_first_annot (a :: others) rest - in - extract_first_annot [] annot - -let extract_first_field_annot annot = extract_first_annot annot '%' -let extract_first_var_annot annot = extract_first_annot annot '@' - -let extract_field_annots annot = - List.partition (fun a -> - match a.[0] with - | '%' -> true - | _ -> false - | exception Invalid_argument _ -> false - ) annot - -let expand_set_caddadr original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len >= 7 - && String.sub str 0 5 = "SET_C" - && String.get str (len - 1) = 'R' - && check_letters str 5 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - begin match extract_field_annots annot with - | [], annot -> ok (None, annot) - | [f], annot -> ok (Some f, annot) - | _, _ -> error (Unexpected_macro_annotation str) - end >>? fun (field_annot, annot) -> - let rec parse i acc = - if i = 4 then - acc - else - let annot = if i = 5 then annot else [] in - match String.get str i with - | 'A' -> - let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CAR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in - parse (i - 1) acc - | 'D' -> - let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CDR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in - parse (i - 1) acc - | _ -> assert false in - match String.get str (len - 2) with - | 'A' -> - let access_check = match field_annot with - | None -> [] - | Some f -> [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CAR", [], [ f ]) ; - Prim (loc, "DROP", [], []) ; - ] in - let encoding = [ Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ] in - let pair = [ Prim (loc, "PAIR", [], - [ Option.unopt field_annot ~default:"%" ; "%@" ]) ] in - let init = Seq (loc, access_check @ encoding @ pair) in - ok (Some (parse (len - 3) init)) - | 'D' -> - let access_check = match field_annot with - | None -> [] - | Some f -> [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], [ f ]) ; - Prim (loc, "DROP", [], []) ; - ] in - let encoding = [ Prim (loc, "CAR", [], [ "@%%" ]) ] in - let pair = [ Prim (loc, "PAIR", [], - [ "%@" ; Option.unopt field_annot ~default:"%" ]) ] in - let init = Seq (loc, access_check @ encoding @ pair) in - ok (Some (parse (len - 3) init)) - | _ -> assert false - else - ok None - | _ -> ok None - -let expand_map_caddadr original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len >= 7 - && String.sub str 0 5 = "MAP_C" - && String.get str (len - 1) = 'R' - && check_letters str 5 (len - 2) - (function 'A' | 'D' -> true | _ -> false) then - begin match args with - | [ Seq _ as code ] -> ok code - | [ _ ] -> error (Sequence_expected str) - | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) - end >>? fun code -> - begin match extract_field_annots annot with - | [], annot -> ok (None, annot) - | [f], annot -> ok (Some f, annot) - | _, _ -> error (Unexpected_macro_annotation str) - end >>? fun (field_annot, annot) -> - let rec parse i acc = - if i = 4 then - acc - else - let annot = if i = 5 then annot else [] in - match String.get str i with - | 'A' -> - let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CAR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in - parse (i - 1) acc - | 'D' -> - let acc = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "DIP", - [ Seq (loc, - [ Prim (loc, "CDR", [], [ "@%%" ]) ; - acc ]) ], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in - parse (i - 1) acc - | _ -> assert false in - let cr_annot = match field_annot with - | None -> [] - | Some f -> [ "@" ^ String.sub f 1 (String.length f - 1) ] in - match String.get str (len - 2) with - | 'A' -> - let init = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], [ "@%%" ]) ; - Prim (loc, "DIP", - [ Seq (loc, [ Prim (loc, "CAR", [], cr_annot) ; code ]) ], []) ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "PAIR", [], - [ Option.unopt field_annot ~default:"%" ; "%@"]) ]) in - ok (Some (parse (len - 3) init)) - | 'D' -> - let init = - Seq (loc, - [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CDR", [], cr_annot) ; - code ; - Prim (loc, "SWAP", [], []) ; - Prim (loc, "CAR", [], [ "@%%" ]) ; - Prim (loc, "PAIR", [], - [ "%@" ; Option.unopt field_annot ~default:"%" ]) ]) in - ok (Some (parse (len - 3) init)) - | _ -> assert false - else - ok None - | _ -> ok None - -exception Not_a_roman - -let decimal_of_roman roman = - (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *) - let arabic = ref 0 in - let lastval = ref 0 in - for i = (String.length roman) - 1 downto 0 do - let n = - match roman.[i] with - | 'M' -> 1000 - | 'D' -> 500 - | 'C' -> 100 - | 'L' -> 50 - | 'X' -> 10 - | 'V' -> 5 - | 'I' -> 1 - | _ -> raise_notrace Not_a_roman - in - if Compare.Int.(n < !lastval) - then arabic := !arabic - n - else arabic := !arabic + n; - lastval := n - done; - !arabic - -let expand_dxiiivp original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str (len - 1) = 'P' then - try - let depth = decimal_of_roman (String.sub str 1 (len - 2)) in - let rec make i acc = - if i = 0 then - acc - else - make (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in - match args with - | [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg) - | [ _ ] -> error (Sequence_expected str) - | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) - with Not_a_roman -> ok None - else ok None - | _ -> ok None - -exception Not_a_pair - -let rec dip ~loc depth instr = - if depth <= 0 - then instr - else dip ~loc (depth - 1) (Prim (loc, "DIP", [ Seq (loc, [ instr ]) ], [])) - -type pair_item = - | A - | I - | P of int * pair_item * pair_item - -let parse_pair_substr str ~len start = - let rec parse ?left i = - if i = len - 1 then - raise_notrace Not_a_pair - else if String.get str i = 'P' then - let next_i, l = parse ~left:true (i + 1) in - let next_i, r = parse ~left:false next_i in - next_i, P (i, l, r) - else if String.get str i = 'A' && left = Some true then - i + 1, A - else if String.get str i = 'I' && left <> Some true then - i + 1, I - else - raise_notrace Not_a_pair in - let last, ast = parse start in - if last <> len - 1 then - raise_notrace Not_a_pair - else - ast - -let unparse_pair_item ast = - let rec unparse ast acc = match ast with - | P (_, l, r) -> unparse r (unparse l ("P" :: acc)) - | A -> "A" :: acc - | I -> "I" :: acc in - List.rev ("R" :: unparse ast []) |> String.concat "" - -let pappaiir_annots_pos ast annot = - let rec find_annots_pos p_pos ast annots acc = - match ast, annots with - | _, [] -> annots, acc - | P (i, left, right), _ -> - let annots, acc = find_annots_pos i left annots acc in - find_annots_pos i right annots acc - | A, a :: annots -> - let pos = match IntMap.find_opt p_pos acc with - | None -> [ a ], [] - | Some (_, cdr) -> [ a ], cdr in - annots, IntMap.add p_pos pos acc - | I, a :: annots -> - let pos = match IntMap.find_opt p_pos acc with - | None -> [], [ a ] - | Some (car, _) -> car, [ a ] in - annots, IntMap.add p_pos pos acc in - snd (find_annots_pos 0 ast annot IntMap.empty) - -let expand_pappaiir original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len > 4 - && String.get str 0 = 'P' - && String.get str (len - 1) = 'R' - && check_letters str 1 (len - 2) - (function 'P' | 'A' | 'I' -> true | _ -> false) then - try - let field_annots, annot = extract_field_annots annot in - let ast = parse_pair_substr str ~len 0 in - let field_annots_pos = pappaiir_annots_pos ast field_annots in - let rec parse p (depth, acc) = - match p with - | P (i, left, right) -> - let annot = - match i, IntMap.find_opt i field_annots_pos with - | 0, None -> annot - | _, None -> [] - | 0, Some ([], cdr_annot) -> "%" :: cdr_annot @ annot - | _, Some ([], cdr_annot) -> "%" :: cdr_annot - | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot - | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot - in - let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in - (depth, acc) - |> parse left - |> parse right - | A | I -> (depth + 1, acc) - in - let _, expanded = parse ast (0, []) in - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - ok (Some (Seq (loc, expanded))) - with Not_a_pair -> ok None - else - ok None - | _ -> ok None - -let expand_unpappaiir original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len >= 6 - && String.sub str 0 3 = "UNP" - && String.get str (len - 1) = 'R' - && check_letters str 3 (len - 2) - (function 'P' | 'A' | 'I' -> true | _ -> false) then - try - let unpair car_annot cdr_annot = - Seq (loc, [ Prim (loc, "DUP", [], []) ; - Prim (loc, "CAR", [], car_annot) ; - dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ; - ]) in - let ast = parse_pair_substr str ~len 2 in - let annots_pos = pappaiir_annots_pos ast annot in - let rec parse p (depth, acc) = - match p with - | P (i, left, right) -> - let car_annot, cdr_annot = - match IntMap.find_opt i annots_pos with - | None -> [], [] - | Some (car_annot, cdr_annot) -> car_annot, cdr_annot in - let acc = dip ~loc depth (unpair car_annot cdr_annot) :: acc in - (depth, acc) - |> parse left - |> parse right - | A | I -> (depth + 1, acc) in - let _, rev_expanded = parse ast (0, []) in - let expanded = Seq (loc, List.rev rev_expanded) in - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - ok (Some expanded) - with Not_a_pair -> ok None - else - ok None - | _ -> ok None - -exception Not_a_dup - -let expand_duuuuup original = - match original with - | Prim (loc, str, args, annot) -> - let len = String.length str in - if len > 3 - && String.get str 0 = 'D' - && String.get str (len - 1) = 'P' - && check_letters str 1 (len - 2) ((=) 'U') then - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) - end >>? fun () -> - try - let rec parse i acc = - if i = 1 then acc - else if String.get str i = 'U' then - parse (i - 1) - (Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ; - Prim (loc, "SWAP", [], []) ])) - else - raise_notrace Not_a_dup in - ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ])))) - with Not_a_dup -> ok None - else - ok None - | _ -> ok None - -let expand_compare original = - let cmp loc is annot = - let is = - match List.rev_map (fun i -> Prim (loc, i, [], [])) is with - | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) - | is -> List.rev is - in - ok (Some (Seq (loc, is))) in - let ifcmp loc is l r annot = - let is = - List.map (fun i -> Prim (loc, i, [], [])) is @ - [ Prim (loc, "IF", [ l ; r ], annot) ] in - ok (Some (Seq (loc, is))) in - match original with - | Prim (loc, "CMPEQ", [], annot) -> - cmp loc [ "COMPARE" ; "EQ" ] annot - | Prim (loc, "CMPNEQ", [], annot) -> - cmp loc [ "COMPARE" ; "NEQ" ] annot - | Prim (loc, "CMPLT", [], annot) -> - cmp loc [ "COMPARE" ; "LT" ] annot - | Prim (loc, "CMPGT", [], annot) -> - cmp loc [ "COMPARE" ; "GT" ] annot - | Prim (loc, "CMPLE", [], annot) -> - cmp loc [ "COMPARE" ; "LE" ] annot - | Prim (loc, "CMPGE", [], annot) -> - cmp loc [ "COMPARE" ; "GE" ] annot - | Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT" - | "CMPGT" | "CMPLE" | "CMPGE" as str), args, []) -> - error (Invalid_arity (str, List.length args, 0)) - | Prim (loc, "IFCMPEQ", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "EQ" ] l r annot - | Prim (loc, "IFCMPNEQ", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "NEQ" ] l r annot - | Prim (loc, "IFCMPLT", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "LT" ] l r annot - | Prim (loc, "IFCMPGT", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "GT" ] l r annot - | Prim (loc, "IFCMPLE", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "LE" ] l r annot - | Prim (loc, "IFCMPGE", [ l ; r ], annot) -> - ifcmp loc [ "COMPARE" ; "GE" ] l r annot - | Prim (loc, "IFEQ", [ l ; r ], annot) -> - ifcmp loc [ "EQ" ] l r annot - | Prim (loc, "IFNEQ", [ l ; r ], annot) -> - ifcmp loc [ "NEQ" ] l r annot - | Prim (loc, "IFLT", [ l ; r ], annot) -> - ifcmp loc [ "LT" ] l r annot - | Prim (loc, "IFGT", [ l ; r ], annot) -> - ifcmp loc [ "GT" ] l r annot - | Prim (loc, "IFLE", [ l ; r ], annot) -> - ifcmp loc [ "LE" ] l r annot - | Prim (loc, "IFGE", [ l ; r ], annot) -> - ifcmp loc [ "GE" ] l r annot - | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" - | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" - | "IFEQ" | "IFNEQ" | "IFLT" - | "IFGT" | "IFLE" | "IFGE" as str), args, []) -> - error (Invalid_arity (str, List.length args, 2)) - | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" - | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" - | "IFEQ" | "IFNEQ" | "IFLT" - | "IFGT" | "IFLE" | "IFGE" as str), [], _ :: _) -> - error (Unexpected_macro_annotation str) - | _ -> ok None - -let expand_asserts original = - let may_rename loc = function - | [] -> Seq (loc, []) - | annot -> Seq (loc, [ Prim (loc, "RENAME", [], annot) ]) - in - let fail_false ?(annot=[]) loc = - [may_rename loc annot; Seq (loc, [ Prim (loc, "FAIL", [], []) ])] - in - let fail_true ?(annot=[]) loc = - [Seq (loc, [ Prim (loc, "FAIL", [], []) ]); may_rename loc annot] - in - match original with - | Prim (loc, "ASSERT", [], []) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ])) - | Prim (loc, "ASSERT_NONE", [], []) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ])) - | Prim (loc, "ASSERT_SOME", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true ~annot loc, []) ])) - | Prim (loc, "ASSERT_LEFT", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false ~annot loc, []) ])) - | Prim (loc, "ASSERT_RIGHT", [], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true ~annot loc, []) ])) - | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" - | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, []) -> - error (Invalid_arity (str, List.length args, 0)) - | Prim (_, ( "ASSERT" | "ASSERT_NONE" as str), [], _ :: _) -> - error (Unexpected_macro_annotation str) - | Prim (loc, s, args, annot) - when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> - begin match args with - | [] -> ok () - | _ :: _ -> error (Invalid_arity (s, List.length args, 0)) - end >>? fun () -> - begin match annot with - | _ :: _ -> (error (Unexpected_macro_annotation s)) - | [] -> ok () - end >>? fun () -> - begin - let remaining = String.(sub s 7 (length s - 7)) in - let remaining_prim = Prim (loc, remaining, [], []) in - match remaining with - | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> - ok @@ Some (Seq (loc, [ remaining_prim ; - Prim (loc, "IF", fail_false loc, []) ])) - | _ -> - begin - expand_compare remaining_prim >|? function - | None -> None - | Some seq -> - Some (Seq (loc, [ seq ; - Prim (loc, "IF", fail_false loc, []) ])) - end - end - | _ -> ok None - - -let expand_if_some = function - | Prim (loc, "IF_SOME", [ right ; left ], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], annot) ])) - | Prim (_, "IF_SOME", args, _annot) -> - error (Invalid_arity ("IF_SOME", List.length args, 2)) - | _ -> ok @@ None - -let expand_if_right = function - | Prim (loc, "IF_RIGHT", [ right ; left ], annot) -> - ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], annot) ])) - | Prim (_, "IF_RIGHT", args, _annot) -> - error (Invalid_arity ("IF_RIGHT", List.length args, 2)) - | _ -> ok @@ None - -let expand_fail = function - | Prim (loc, "FAIL", [], []) -> - ok @@ Some (Seq (loc, [ - Prim (loc, "UNIT", [], []) ; - Prim (loc, "FAILWITH", [], []) ; - ])) - | _ -> ok @@ None - -let expand original = - let rec try_expansions = function - | [] -> ok @@ original - | expander :: expanders -> - expander original >>? function - | None -> try_expansions expanders - | Some rewritten -> ok rewritten in - try_expansions - [ expand_caddadr ; - expand_set_caddadr ; - expand_map_caddadr ; - expand_dxiiivp ; - (* expand_paaiair ; *) - expand_pappaiir ; - (* expand_unpaaiair ; *) - expand_unpappaiir ; - expand_duuuuup ; - expand_compare ; - expand_asserts ; - expand_if_some ; - expand_if_right ; - expand_fail ; - ] - -let expand_rec expr = - let rec error_map (expanded, errors) f = function - | [] -> (List.rev expanded, List.rev errors) - | hd :: tl -> - let (new_expanded, new_errors) = f hd in - error_map - (new_expanded :: expanded, List.rev_append new_errors errors) - f tl in - let error_map = error_map ([], []) in - let rec expand_rec expr = - match expand expr with - | Ok expanded -> - begin - match expanded with - | Seq (loc, items) -> - let items, errors = error_map expand_rec items in - (Seq (loc, items), errors) - | Prim (loc, name, args, annot) -> - let args, errors = error_map expand_rec args in - (Prim (loc, name, args, annot), errors) - | Int _ | String _ | Bytes _ as atom -> (atom, []) end - | Error errors -> (expr, errors) in - expand_rec expr - -let unexpand_caddadr expanded = - let rec rsteps acc = function - | [] -> Some acc - | Prim (_, "CAR" , [], []) :: rest -> - rsteps ("A" :: acc) rest - | Prim (_, "CDR" , [], []) :: rest -> - rsteps ("D" :: acc) rest - | _ -> None in - match expanded with - | Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes)) - | Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) -> - begin match rsteps [] nodes with - | Some steps -> - let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [], [])) - | None -> None - end - | _ -> None - -let unexpand_set_caddadr expanded = - let rec steps acc annots = function - | Seq (loc, - [ Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], _) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "A" :: acc, annots) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], [ field_annot ]) ; - Prim (_, "DROP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "A" :: acc, field_annot :: annots) - | Seq (loc, - [ Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "D" :: acc, annots) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], [ field_annot ]) ; - Prim (_, "DROP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "D" :: acc, field_annot :: annots) - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], _) ; - sub ]) ], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in - steps ("A" :: acc) (List.rev_append pair_annots annots) sub - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], _) ; - sub ]) ], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in - steps ("D" :: acc) (List.rev_append pair_annots annots) sub - | _ -> None in - match steps [] [] expanded with - | Some (loc, steps, annots) -> - let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [], List.rev annots)) - | None -> None - -let unexpand_map_caddadr expanded = - let rec steps acc annots = function - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], []) ; - code ]) ], []) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "A" :: acc, annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], [ field_annot ]) ; - code ]) ], []) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "A" :: acc, field_annot :: annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], []) ; - code ; - Prim (_, "SWAP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "D" :: acc, annots, code) - | Seq (loc, - [ Prim (_, "DUP", [], []) ; - Prim (_, "CDR", [], [ field_annot ]) ; - code ; - Prim (_, "SWAP", [], []) ; - Prim (_, "CAR", [], _) ; - Prim (_, "PAIR", [], _) ]) -> - Some (loc, "D" :: acc, field_annot :: annots, code) - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CAR", [], _) ; - sub ]) ], []) ; - Prim (_, "CDR", [], _) ; - Prim (_, "SWAP", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in - steps ("A" :: acc) (List.rev_append pair_annots annots) sub - | Seq (_, - [ Prim (_, "DUP", [], []) ; - Prim (_, "DIP", - [ Seq (_, - [ Prim (_, "CDR", [], []) ; - sub ]) ], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "PAIR", [], pair_annots) ]) -> - let _, pair_annots = extract_field_annots pair_annots in - steps ("D" :: acc) (List.rev_append pair_annots annots) sub - | _ -> None in - match steps [] [] expanded with - | Some (loc, steps, annots, code) -> - let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in - Some (Prim (loc, name, [ code ], List.rev annots)) - | None -> None - -let roman_of_decimal decimal = - (* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *) - let digit x y z = function - | 1 -> [ x ] - | 2 -> [ x ; x ] - | 3 -> [ x ; x ; x ] - | 4 -> [ x ; y ] - | 5 -> [ y ] - | 6 -> [ y ; x ] - | 7 -> [ y ; x ; x ] - | 8 -> [ y ; x ; x ; x ] - | 9 -> [ x ; z ] - | _ -> assert false in - let rec to_roman x = - if x = 0 then [] - else if x < 0 then - invalid_arg "Negative roman numeral" - else if x >= 1000 then - "M" :: to_roman (x - 1000) - else if x >= 100 then - digit "C" "D" "M" (x / 100) @ to_roman (x mod 100) - else if x >= 10 then - digit "X" "L" "C" (x / 10) @ to_roman (x mod 10) - else - digit "I" "V" "X" x in - String.concat "" (to_roman decimal) - -let dxiiivp_roman_of_decimal decimal = - let roman = roman_of_decimal decimal in - if String.length roman = 1 then - (* too short for D*P, fall back to IIIII... *) - String.concat "" (List.init decimal (fun _ -> "I")) - else - roman - -let unexpand_dxiiivp expanded = - match expanded with - | Seq (loc, - [ Prim (_, "DIP", - [ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ], - []) ]) -> - let rec count acc = function - | Seq (_, [ Prim (_, "DIP", [ sub ], []) ]) -> count (acc + 1) sub - | sub -> (acc, sub) in - let depth, sub = count 1 sub in - let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in - Some (Prim (loc, name, [ sub ], [])) - | _ -> None - -let unexpand_duuuuup expanded = - let rec help expanded = - match expanded with - | Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1) - | Seq (_, [ Prim (_, "DIP", [expanded'], []); - Prim (_, "SWAP", [], []) ]) -> - begin - match help expanded' with - | None -> None - | Some (loc, n) -> Some (loc, n + 1) - end - | _ -> None - in let rec dupn = function - | 0 -> "P" - | n -> "U" ^ (dupn (n - 1)) in - match help expanded with - | None -> None - | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], [])) - -let rec normalize_pair_item ?(right=false) = function - | P (i, a, b) -> P (i, normalize_pair_item a, normalize_pair_item ~right:true b) - | A when right -> I - | A -> A - | I -> I - -let unexpand_pappaiir expanded = - match expanded with - | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded - | Seq (loc, (_ :: _ as nodes)) -> - let rec exec stack nodes = match nodes, stack with - | [], _ -> stack - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> - exec (a :: exec rstack sub) rest - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> - exec (A :: exec [] sub) rest - | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> - exec (P (0, a, b) :: rstack) rest - | Prim (_, "PAIR", [], []) :: rest, [ a ] -> - exec [ P (0, a, I) ] rest - | Prim (_, "PAIR", [], []) :: rest, [] -> - exec [ P (0, A, I) ] rest - | _ -> raise_notrace Not_a_pair in - begin match exec [] nodes with - | [] -> None - | res :: _ -> - let res = normalize_pair_item res in - let name = unparse_pair_item res in - Some (Prim (loc, name, [], [])) - | exception Not_a_pair -> None - end - | _ -> None - -let unexpand_unpappaiir expanded = - match expanded with - | Seq (loc, (_ :: _ as nodes)) -> - let rec exec stack nodes = match nodes, stack with - | [], _ -> stack - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> - exec (a :: exec rstack sub) rest - | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> - exec (A :: exec [] sub) rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - a :: b :: rstack -> - exec (P (0, a, b) :: rstack) rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - [ a ] -> - exec [ P (0, a, I) ] rest - | Seq (_, [ Prim (_, "DUP", [], []) ; - Prim (_, "CAR", [], []) ; - Prim (_, "DIP", - [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], - []) ]) :: rest, - [] -> - exec [ P (0, A, I) ] rest - | _ -> raise_notrace Not_a_pair in - begin match exec [] (List.rev nodes) with - | [] -> None - | res :: _ -> - let res = normalize_pair_item res in - let name = "UN" ^ unparse_pair_item res in - Some (Prim (loc, name, [], [])) - | exception Not_a_pair -> None - end - | _ -> None - - -let unexpand_compare expanded = - match expanded with - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "EQ", [], annot) ]) -> - Some (Prim (loc, "CMPEQ", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "NEQ", [], annot) ]) -> - Some (Prim (loc, "CMPNEQ", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LT", [], annot) ]) -> - Some (Prim (loc, "CMPLT", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GT", [], annot) ]) -> - Some (Prim (loc, "CMPGT", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LE", [], annot) ]) -> - Some (Prim (loc, "CMPLE", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GE", [], annot) ]) -> - Some (Prim (loc, "CMPGE", [], annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "EQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPEQ", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "NEQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPNEQ", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LT", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPLT", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GT", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPGT", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "LE", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPLE", args, annot)) - | Seq (loc, [ Prim (_, "COMPARE", [], _) ; - Prim (_, "GE", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFCMPGE", args, annot)) - | Seq (loc, [ Prim (_, "EQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFEQ", args, annot)) - | Seq (loc, [ Prim (_, "NEQ", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFNEQ", args, annot)) - | Seq (loc, [ Prim (_, "LT", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFLT", args, annot)) - | Seq (loc, [ Prim (_, "GT", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFGT", args, annot)) - | Seq (loc, [ Prim (_, "LE", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFLE", args, annot)) - | Seq (loc, [ Prim (_, "GE", [], _) ; - Prim (_, "IF", args, annot) ]) -> - Some (Prim (loc, "IFGE", args, annot)) - | _ -> None - -let unexpand_asserts expanded = - match expanded with - | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT", [], [])) - | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ; - Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], [])) - | Seq (loc, [ Prim (_, comparison, [], []) ; - Prim (_, "IF", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_" ^ comparison, [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_NONE", [], annot)) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_NONE", [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [])], - []) ]) -> - Some (Prim (loc, "ASSERT_SOME", [], [])) - | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [ Prim (_, "RENAME", [], annot) ])], - []) ]) -> - Some (Prim (loc, "ASSERT_SOME", [], annot)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_LEFT", [], [])) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; - Seq (_, [ - Seq (_, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_LEFT", [], annot)) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, []) ], - []) ]) -> - Some (Prim (loc, "ASSERT_RIGHT", [], [])) - | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ]) ]) ; - Seq (_, [ Prim (_, "RENAME", [], annot) ]) ], - []) ]) -> - Some (Prim (loc, "ASSERT_RIGHT", [], annot)) - | _ -> None - - -let unexpand_if_some = function - | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], annot) ]) -> - Some (Prim (loc, "IF_SOME", [ right ; left ], annot)) - | _ -> None - -let unexpand_if_right = function - | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], annot) ]) -> - Some (Prim (loc, "IF_RIGHT", [ right ; left ], annot)) - | _ -> None - -let unexpand_fail = function - | Seq (loc, [ - Prim (_, "UNIT", [], []) ; - Prim (_, "FAILWITH", [], []) ; - ]) -> - Some (Prim (loc, "FAIL", [], [])) - | _ -> None - -let unexpand original = - let try_unexpansions unexpanders = - match - List.fold_left - (fun acc f -> - match acc with - | None -> f original - | Some rewritten -> Some rewritten) - None unexpanders with - | None -> original - | Some rewritten -> rewritten in - try_unexpansions - [ unexpand_asserts ; - unexpand_caddadr ; - unexpand_set_caddadr ; - unexpand_map_caddadr ; - unexpand_dxiiivp ; - unexpand_pappaiir ; - unexpand_unpappaiir ; - unexpand_duuuuup ; - unexpand_compare ; - unexpand_if_some ; - unexpand_if_right ; - unexpand_fail ] - -let rec unexpand_rec expr = - match unexpand expr with - | Seq (loc, items) -> - Seq (loc, List.map unexpand_rec items) - | Prim (loc, name, args, annot) -> - Prim (loc, name, List.map unexpand_rec args, annot) - | Int _ | String _ | Bytes _ as atom -> atom - -let () = - let open Data_encoding in - register_error_kind - `Permanent - ~id:"michelson.macros.unexpected_annotation" - ~title:"Unexpected annotation" - ~description:"A macro had an annotation, but no annotation was permitted on this macro." - ~pp:(fun ppf -> - Format.fprintf ppf - "Unexpected annotation on macro %s.") - (obj1 - (req "macro_name" string)) - (function - | Unexpected_macro_annotation str -> Some str - | _ -> None) - (fun s -> Unexpected_macro_annotation s) ; - register_error_kind - `Permanent - ~id:"michelson.macros.sequence_expected" - ~title:"Macro expects a sequence" - ~description:"An macro expects a sequence, but a sequence was not provided" - ~pp:(fun ppf name -> - Format.fprintf ppf - "Macro %s expects a sequence, but did not receive one." name) - (obj1 - (req "macro_name" string)) - (function - | Sequence_expected name -> Some name - | _ -> None) - (fun name -> Sequence_expected name) ; - register_error_kind - `Permanent - ~id:"michelson.macros.bas_arity" - ~title:"Wrong number of arguments to macro" - ~description:"A wrong number of arguments was provided to a macro" - ~pp:(fun ppf (name, got, exp) -> - Format.fprintf ppf - "Macro %s expects %d arguments, was given %d." name got exp) - (obj3 - (req "macro_name" string) - (req "given_number_of_arguments" uint16) - (req "expected_number_of_arguments" uint16)) - (function - | Invalid_arity (name, got, exp) -> Some (name, got, exp) - | _ -> None) - (fun (name, got, exp) -> Invalid_arity (name, got, exp)) diff --git a/src/lib_utils/michelson-parser/michelson_v1_macros.mli b/src/lib_utils/michelson-parser/michelson_v1_macros.mli deleted file mode 100644 index 4a614cbc0..000000000 --- a/src/lib_utils/michelson-parser/michelson_v1_macros.mli +++ /dev/null @@ -1,62 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Tezos_micheline - -type 'l node = ('l, string) Micheline.node - -type error += Unexpected_macro_annotation of string -type error += Sequence_expected of string -type error += Invalid_arity of string * int * int - -val expand : 'l node -> 'l node tzresult -val expand_rec : 'l node -> 'l node * error list - -val expand_caddadr : 'l node -> 'l node option tzresult -val expand_set_caddadr : 'l node -> 'l node option tzresult -val expand_map_caddadr : 'l node -> 'l node option tzresult -val expand_dxiiivp : 'l node -> 'l node option tzresult -val expand_pappaiir : 'l node -> 'l node option tzresult -val expand_duuuuup : 'l node -> 'l node option tzresult -val expand_compare : 'l node -> 'l node option tzresult -val expand_asserts : 'l node -> 'l node option tzresult -val expand_unpappaiir : 'l node -> 'l node option tzresult -val expand_if_some : 'l node -> 'l node option tzresult -val expand_if_right : 'l node -> 'l node option tzresult - -val unexpand : 'l node -> 'l node -val unexpand_rec : 'l node -> 'l node - -val unexpand_caddadr : 'l node -> 'l node option -val unexpand_set_caddadr : 'l node -> 'l node option -val unexpand_map_caddadr : 'l node -> 'l node option -val unexpand_dxiiivp : 'l node -> 'l node option -val unexpand_pappaiir : 'l node -> 'l node option -val unexpand_duuuuup : 'l node -> 'l node option -val unexpand_compare : 'l node -> 'l node option -val unexpand_asserts : 'l node -> 'l node option -val unexpand_unpappaiir : 'l node -> 'l node option -val unexpand_if_some : 'l node -> 'l node option -val unexpand_if_right : 'l node -> 'l node option diff --git a/src/lib_utils/michelson-parser/v1.ml b/src/lib_utils/michelson-parser/v1.ml deleted file mode 100644 index 1c203482c..000000000 --- a/src/lib_utils/michelson-parser/v1.ml +++ /dev/null @@ -1,91 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Memory_proto_alpha -open Tezos_micheline -open Micheline_parser -open Micheline - -type parsed = - { source : string ; - unexpanded : string canonical ; - expanded : Michelson_v1_primitives.prim canonical ; - expansion_table : (int * (Micheline_parser.location * int list)) list ; - unexpansion_table : (int * int) list } - -(* Unexpanded toplevel expression should be a sequence *) -let expand_all source ast errors = - let unexpanded, loc_table = - extract_locations ast in - let expanded, expansion_errors = - Michelson_v1_macros.expand_rec (root unexpanded) in - let expanded, unexpansion_table = - extract_locations expanded in - let expansion_table = - let sorted = - List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in - let grouped = - let rec group = function - | acc, [] -> acc - | [], (u, e) :: r -> - group ([ (e, [ u ]) ], r) - | ((pe, us) :: racc as acc), (u, e) :: r -> - if e = pe then - group (((e, u :: us) :: racc), r) - else - group (((e, [ u ]) :: acc), r) in - group ([], sorted) in - List.map2 - (fun (l, ploc) (l', elocs) -> - assert (l = l') ; - (l, (ploc, elocs))) - (List.sort compare loc_table) - (List.sort compare grouped) in - match Alpha_environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) with - | Ok expanded -> - { source ; unexpanded ; expanded ; - expansion_table ; unexpansion_table }, - errors @ expansion_errors - | Error errs -> - { source ; unexpanded ; - expanded = Micheline.strip_locations (Seq ((), [])) ; - expansion_table ; unexpansion_table }, - errors @ expansion_errors @ errs - -let parse_toplevel ?check source = - let tokens, lexing_errors = Micheline_parser.tokenize source in - let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in - let ast = - let start = min_point asts and stop = max_point asts in - Seq ({ start ; stop }, asts) in - expand_all source ast (lexing_errors @ parsing_errors) - -let parse_expression ?check source = - let tokens, lexing_errors = Micheline_parser.tokenize source in - let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in - expand_all source ast (lexing_errors @ parsing_errors) - -let expand_all ~source ~original = - expand_all source original [] diff --git a/src/lib_utils/michelson-parser/v1.mli b/src/lib_utils/michelson-parser/v1.mli deleted file mode 100644 index 2f0980e32..000000000 --- a/src/lib_utils/michelson-parser/v1.mli +++ /dev/null @@ -1,51 +0,0 @@ -(*****************************************************************************) -(* *) -(* Open Source License *) -(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) -(* *) -(* Permission is hereby granted, free of charge, to any person obtaining a *) -(* copy of this software and associated documentation files (the "Software"),*) -(* to deal in the Software without restriction, including without limitation *) -(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) -(* and/or sell copies of the Software, and to permit persons to whom the *) -(* Software is furnished to do so, subject to the following conditions: *) -(* *) -(* The above copyright notice and this permission notice shall be included *) -(* in all copies or substantial portions of the Software. *) -(* *) -(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) -(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) -(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) -(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) -(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) -(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) -(* DEALINGS IN THE SOFTWARE. *) -(* *) -(*****************************************************************************) - -open Memory_proto_alpha -open Alpha_context - -open Tezos_micheline - -(** The result of parsing and expanding a Michelson V1 script or data. *) -type parsed = - { - source : string ; - (** The original source code. *) - unexpanded : string Micheline.canonical ; - (** Original expression with macros. *) - expanded : Script.expr ; - (** Expression with macros fully expanded. *) - expansion_table : - (int * (Micheline_parser.location * int list)) list ; - (** Associates unexpanded nodes to their parsing locations and - the nodes expanded from it in the expanded expression. *) - unexpansion_table : (int * int) list ; - (** Associates an expanded node to its source in the unexpanded - expression. *) - } - -val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result -val parse_expression : ?check:bool -> string -> parsed Micheline_parser.parsing_result -val expand_all : source:string -> original:Micheline_parser.node -> parsed Micheline_parser.parsing_result diff --git a/src/lib_utils/ne_list.ml b/src/lib_utils/ne_list.ml deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/lib_utils/pos.ml b/src/lib_utils/pos.ml deleted file mode 100644 index b4475aa6e..000000000 --- a/src/lib_utils/pos.ml +++ /dev/null @@ -1,138 +0,0 @@ -type t = < - byte : Lexing.position; - point_num : int; - point_bol : int; - file : string; - line : int; - - set_file : string -> t; - set_line : int -> t; - set_offset : int -> t; - set : file:string -> line:int -> offset:int -> t; - new_line : string -> t; - add_nl : t; - - shift_bytes : int -> t; - shift_one_uchar : int -> t; - - offset : [`Byte | `Point] -> int; - column : [`Byte | `Point] -> int; - - line_offset : [`Byte | `Point] -> int; - byte_offset : int; - - is_ghost : bool; - - to_string : ?offsets:bool -> [`Byte | `Point] -> string; - compact : ?offsets:bool -> [`Byte | `Point] -> string; - anonymous : ?offsets:bool -> [`Byte | `Point] -> string -> - -type pos = t - -(* Constructors *) - -let sprintf = Printf.sprintf - -let make ~byte ~point_num ~point_bol = - let () = assert (point_num >= point_bol) in - object (self) - val byte = byte - method byte = byte - - val point_num = point_num - method point_num = point_num - - val point_bol = point_bol - method point_bol = point_bol - - method set_file file = - {< byte = Lexing.{byte with pos_fname = file} >} - - method set_line line = - {< byte = Lexing.{byte with pos_lnum = line} >} - - method set_offset offset = - {< byte = Lexing.{byte with pos_cnum = byte.pos_bol + offset} >} - - method set ~file ~line ~offset = - let pos = self#set_file file in - let pos = pos#set_line line in - let pos = pos#set_offset offset - in pos - - (* The string must not contain '\n'. See [new_line]. *) - - method shift_bytes len = - {< byte = Lexing.{byte with pos_cnum = byte.pos_cnum + len}; - point_num = point_num + len >} - - method shift_one_uchar len = - {< byte = Lexing.{byte with pos_cnum = byte.pos_cnum + len}; - point_num = point_num + 1 >} - - method add_nl = - {< byte = Lexing.{byte with - pos_lnum = byte.pos_lnum + 1; - pos_bol = byte.pos_cnum}; - point_bol = point_num >} - - method new_line string = - let len = String.length string - in (self#shift_bytes len)#add_nl - - method is_ghost = byte = Lexing.dummy_pos - - method file = byte.Lexing.pos_fname - - method line = byte.Lexing.pos_lnum - - method offset = function - `Byte -> Lexing.(byte.pos_cnum - byte.pos_bol) - | `Point -> point_num - point_bol - - method column mode = 1 + self#offset mode - - method line_offset = function - `Byte -> byte.Lexing.pos_bol - | `Point -> point_bol - - method byte_offset = byte.Lexing.pos_cnum - - method to_string ?(offsets=true) mode = - let offset = self#offset mode in - let horizontal, value = - if offsets then "character", offset else "column", offset + 1 - in sprintf "File \"%s\", line %i, %s %i" - self#file self#line horizontal value - - method compact ?(offsets=true) mode = - if self#is_ghost then "ghost" - else - let offset = self#offset mode in - sprintf "%s:%i:%i" - self#file self#line (if offsets then offset else offset + 1) - - method anonymous ?(offsets=true) mode = - if self#is_ghost then "ghost" - else sprintf "%i:%i" self#line - (if offsets then self#offset mode else self#column mode) -end - -let ghost = make ~byte:Lexing.dummy_pos ~point_num:(-1) ~point_bol:(-1) - -let min = - let byte = Lexing.{ - pos_fname = ""; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0} - in make ~byte ~point_num:0 ~point_bol:0 - -(* Comparisons *) - -let equal pos1 pos2 = - pos1#file = pos2#file && pos1#byte_offset = pos2#byte_offset - -let lt pos1 pos2 = - pos1#file = pos2#file && pos1#byte_offset < pos2#byte_offset diff --git a/src/lib_utils/pos.mli b/src/lib_utils/pos.mli deleted file mode 100644 index 998ea9b62..000000000 --- a/src/lib_utils/pos.mli +++ /dev/null @@ -1,107 +0,0 @@ -(* Positions in a file - - A position in a file denotes a single unit belonging to it, for - example, in an ASCII text file, it is a particular character within - that file (the unit is the byte in this instance, since in ASCII - one character is encoded with one byte). - - Units can be either bytes (as ASCII characters) or, more - generally, unicode points. - - The type for positions is the object type [t]. - - We use here lexing positions to denote byte-oriented positions - (field [byte]), and we manage code points by means of the fields - [point_num] and [point_bol]. These two fields have a meaning - similar to the fields [pos_cnum] and [pos_bol], respectively, from - the standard module [Lexing]. That is to say, [point_num] holds the - number of code points since the beginning of the file, and - [point_bol] the number of code points since the beginning of the - current line. - - The name of the file is given by the field [file], and the line - number by the field [line]. -*) - -type t = < - (* Payload *) - - byte : Lexing.position; - point_num : int; - point_bol : int; - file : string; - line : int; - - (* Setters *) - - set_file : string -> t; - set_line : int -> t; - set_offset : int -> t; - set : file:string -> line:int -> offset:int -> t; - - (* The call [pos#new_line s], where the string [s] is either "\n" or - "\c\r", updates the position [pos] with a new line. *) - - new_line : string -> t; - add_nl : t; - - (* The call [pos#shift_bytes n] evaluates in a position that is the - translation of position [pos] of [n] bytes forward in the - file. The call [pos#shift_one_uchar n] is similar, except that it - assumes that [n] is the number of bytes making up one unicode - point. *) - - shift_bytes : int -> t; - shift_one_uchar : int -> t; - - (* Getters *) - - (* The call [pos#offset `Byte] provides the horizontal offset of the - position [pos] in bytes. (An offset is the number of units, like - bytes, since the beginning of the current line.) The call - [pos#offset `Point] is the offset counted in number of unicode - points. - - The calls to the method [column] are similar to those to - [offset], except that they give the curren column number. - - The call [pos#line_offset `Byte] is the offset of the line of - position [pos], counted in bytes. Dually, [pos#line_offset - `Point] counts the same offset in code points. - - The call [pos#byte_offset] is the offset of the position [pos] - since the begininng of the file, counted in bytes. - *) - - offset : [`Byte | `Point] -> int; - column : [`Byte | `Point] -> int; - - line_offset : [`Byte | `Point] -> int; - byte_offset : int; - - (* Predicates *) - - is_ghost : bool; - - (* Conversions to [string] *) - - to_string : ?offsets:bool -> [`Byte | `Point] -> string; - compact : ?offsets:bool -> [`Byte | `Point] -> string; - anonymous : ?offsets:bool -> [`Byte | `Point] -> string -> - -type pos = t - -(* Constructors *) - -val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t - -(* Special positions *) - -val ghost : t (* Same as [Lexing.dummy_pos] *) -val min : t (* Lexing convention: line 1, offsets to 0 and file to "". *) - -(* Comparisons *) - -val equal : t -> t -> bool -val lt : t -> t -> bool diff --git a/src/lib_utils/ppx_let_generalized/.gitignore b/src/lib_utils/ppx_let_generalized/.gitignore deleted file mode 100644 index 6c14091bb..000000000 --- a/src/lib_utils/ppx_let_generalized/.gitignore +++ /dev/null @@ -1,5 +0,0 @@ -_build -*.install -*.merlin -_opam - diff --git a/src/lib_utils/ppx_let_generalized/CHANGES.md b/src/lib_utils/ppx_let_generalized/CHANGES.md deleted file mode 100644 index 38594829d..000000000 --- a/src/lib_utils/ppx_let_generalized/CHANGES.md +++ /dev/null @@ -1,17 +0,0 @@ -## git version - -- Support for `%map.A.B.C` syntax to use values from a specific module, rather - than the one in scope. - -## v0.11 - -- Depend on ppxlib instead of (now deprecated) ppx\_core and ppx\_driver. - -## 113.43.00 - -- Dropped `Open_in_body` support from ppx\_let, since it was only ever used - in confusing chains of `Let_syntax` modules that introduced other - `Let_syntax` modules in the "body" (e.g. for defining Commands whose - bodies use Async). In this case it was decided that the better - practice is to be explicit with `open ___.Let_syntax` at the different - transition points, even though this is more verbose. diff --git a/src/lib_utils/ppx_let_generalized/CONTRIBUTING.md b/src/lib_utils/ppx_let_generalized/CONTRIBUTING.md deleted file mode 100644 index 45e1a22b9..000000000 --- a/src/lib_utils/ppx_let_generalized/CONTRIBUTING.md +++ /dev/null @@ -1,67 +0,0 @@ -This repository contains open source software that is developed and -maintained by [Jane Street][js]. - -Contributions to this project are welcome and should be submitted via -GitHub pull requests. - -Signing contributions ---------------------- - -We require that you sign your contributions. Your signature certifies -that you wrote the patch or otherwise have the right to pass it on as -an open-source patch. The rules are pretty simple: if you can certify -the below (from [developercertificate.org][dco]): - -``` -Developer Certificate of Origin -Version 1.1 - -Copyright (C) 2004, 2006 The Linux Foundation and its contributors. -1 Letterman Drive -Suite D4700 -San Francisco, CA, 94129 - -Everyone is permitted to copy and distribute verbatim copies of this -license document, but changing it is not allowed. - - -Developer's Certificate of Origin 1.1 - -By making a contribution to this project, I certify that: - -(a) The contribution was created in whole or in part by me and I - have the right to submit it under the open source license - indicated in the file; or - -(b) The contribution is based upon previous work that, to the best - of my knowledge, is covered under an appropriate open source - license and I have the right under that license to submit that - work with modifications, whether created in whole or in part - by me, under the same open source license (unless I am - permitted to submit under a different license), as indicated - in the file; or - -(c) The contribution was provided directly to me by some other - person who certified (a), (b) or (c) and I have not modified - it. - -(d) I understand and agree that this project and the contribution - are public and that a record of the contribution (including all - personal information I submit with it, including my sign-off) is - maintained indefinitely and may be redistributed consistent with - this project or the open source license(s) involved. -``` - -Then you just add a line to every git commit message: - -``` -Signed-off-by: Joe Smith -``` - -Use your real name (sorry, no pseudonyms or anonymous contributions.) - -If you set your `user.name` and `user.email` git configs, you can sign -your commit automatically with git commit -s. - -[dco]: http://developercertificate.org/ -[js]: https://opensource.janestreet.com/ diff --git a/src/lib_utils/ppx_let_generalized/CREDITS b/src/lib_utils/ppx_let_generalized/CREDITS deleted file mode 100644 index 6a3ab4f2a..000000000 --- a/src/lib_utils/ppx_let_generalized/CREDITS +++ /dev/null @@ -1,4 +0,0 @@ -This folder contains a generalization of ppx_let from Jane Street. -See git log this_folder for the development history. - -https://github.com/janestreet/ppx_let.git diff --git a/src/lib_utils/ppx_let_generalized/LICENSE.md b/src/lib_utils/ppx_let_generalized/LICENSE.md deleted file mode 100644 index 54ac5432f..000000000 --- a/src/lib_utils/ppx_let_generalized/LICENSE.md +++ /dev/null @@ -1,21 +0,0 @@ -The MIT License - -Copyright (c) 2015--2019 Jane Street Group, LLC - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/src/lib_utils/ppx_let_generalized/Makefile b/src/lib_utils/ppx_let_generalized/Makefile deleted file mode 100644 index 1965878e4..000000000 --- a/src/lib_utils/ppx_let_generalized/Makefile +++ /dev/null @@ -1,17 +0,0 @@ -INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) - -default: - dune build - -install: - dune install $(INSTALL_ARGS) - -uninstall: - dune uninstall $(INSTALL_ARGS) - -reinstall: uninstall install - -clean: - dune clean - -.PHONY: default install uninstall reinstall clean diff --git a/src/lib_utils/ppx_let_generalized/README.md b/src/lib_utils/ppx_let_generalized/README.md deleted file mode 100644 index 389a8dbda..000000000 --- a/src/lib_utils/ppx_let_generalized/README.md +++ /dev/null @@ -1,169 +0,0 @@ -ppx_let -======= - -A ppx rewriter for monadic and applicative let bindings, match expressions, and -if expressions. - -Overview --------- - -The aim of this rewriter is to make monadic and applicative code look nicer by -writing custom binders the same way that we normally bind variables. In OCaml, -the common way to bind the result of a computation to a variable is: - -```ocaml -let VAR = EXPR in BODY -``` - -ppx\_let simply adds two new binders: `let%bind` and `let%map`. These are -rewritten into calls to the `bind` and `map` functions respectively. These -functions are expected to have - -```ocaml -val map : 'a t -> f:('a -> 'b) -> 'b t -val bind : 'a t -> f:('a -> 'b t) -> 'b t -``` - -for some type `t`, as one might expect. - -These functions are to be provided by the user, and are generally expected to be -part of the signatures of monads and applicatives modules. This is the case for -all monads and applicatives defined by the Jane Street's Core suite of -libraries. (see the section below on getting the right names into scope). - -### Parallel bindings - -ppx\_let understands parallel bindings as well. i.e.: - -```ocaml -let%bind VAR1 = EXPR1 and VAR2 = EXPR2 and VAR3 = EXPR3 in BODY -``` - -The `and` keyword is seen as a binding combination operator. To do so it expects -the presence of a `both` function, that lifts the OCaml pair operation to the -type `t` in question: - -```ocaml -val both : 'a t -> 'b t -> ('a * 'b) t -``` - -### Match statements - -We found that this form was quite useful for match statements as well. So for -convenience ppx\_let also accepts `%bind` and `%map` on the `match` keyword. -Morally `match%bind expr with cases` is seen as `let%bind x = expr in match x -with cases`. - -### If statements - -As a further convenience, ppx\_let accepts `%bind` and `%map` on the `if` -keyword. The expression `if%bind expr1 then expr2 else expr3` is morally -equivalent to `let%bind p = expr1 in if p then expr2 else expr3`. - -Syntactic forms and actual rewriting ------------------------------------- - -`ppx_let` adds six syntactic forms - -```ocaml -let%bind P = M in E - -let%map P = M in E - -match%bind M with P1 -> E1 | P2 -> E2 | ... - -match%map M with P1 -> E1 | P2 -> E2 | ... - -if%bind M then E1 else E2 - -if%map M then E1 else E2 -``` - -that expand into - -```ocaml -bind M ~f:(fun P -> E) - -map M ~f:(fun P -> E) - -bind M ~f:(function P1 -> E1 | P2 -> E2 | ...) - -map M ~f:(function P1 -> E1 | P2 -> E2 | ...) - -bind M ~f:(function true -> E1 | false -> E2) - -map M ~f:(function true -> E1 | false -> E2) -``` - -respectively. - -As with `let`, `let%bind` and `let%map` also support multiple *parallel* -bindings via the `and` keyword: - -```ocaml -let%bind P1 = M1 and P2 = M2 and P3 = M3 and P4 = M4 in E - -let%map P1 = M1 and P2 = M2 and P3 = M3 and P4 = M4 in E -``` - -that expand into - -```ocaml -let x1 = M1 and x2 = M2 and x3 = M3 and x4 = M4 in -bind - (both x1 (both x2 (both x3 x4))) - ~f:(fun (P1, (P2, (P3, P4))) -> E) - -let x1 = M1 and x2 = M2 and x3 = M3 and x4 = M4 in -map - (both x1 (both x2 (both x3 x4))) - ~f:(fun (P1, (P2, (P3, P4))) -> E) -``` - -respectively. (Instead of `x1`, `x2`, ... ppx\_let uses variable names that are -unlikely to clash with other names) - -As with `let`, names introduced by left-hand sides of the let bindings are not -available in subsequent right-hand sides of the same sequence. - -Getting the right names in scope --------------------------------- - -The description of how the `%bind` and `%map` syntax extensions expand left out -the fact that the names `bind`, `map`, `both`, and `return` are not used -directly., but rather qualified by `Let_syntax`. For example, we use -`Let_syntax.bind` rather than merely `bind`. - -This means one just needs to get a properly loaded `Let_syntax` module -in scope to use `%bind` and `%map`. - -Alternatively, the extension can use values from a `Let_syntax` module -other than the one in scope. If you write `%map.A.B.C` instead of -`%map`, the expansion will use `A.B.C.Let_syntax.map` instead of -`Let_syntax.map` (and similarly for all extension points). - -For monads, `Core.Monad.Make` produces a submodule `Let_syntax` of the -appropriate form. - -For applicatives, the convention for these modules is to have a submodule -`Let_syntax` of the form: - -```ocaml -module Let_syntax : sig - val return : 'a -> 'a t - val map : 'a t -> f:('a -> 'b) -> 'b t - val both : 'a t -> 'b t -> ('a * 'b) t - module Open_on_rhs : << some signature >> -end -``` - -The `Open_on_rhs` submodule is used by variants of `%map` and `%bind` called -`%map_open` and `%bind_open`. It is locally opened on the right hand sides of -the rewritten let bindings in `%map_open` and `%bind_open` expressions. For -`match%map_open` and `match%bind_open` expressions, `Open_on_rhs` is opened for -the expression being matched on. - -`Open_on_rhs` is useful when programming with applicatives, which operate in a -staged manner where the operators used to construct the applicatives are -distinct from the operators used to manipulate the values those applicatives -produce. For monads, `Open_on_rhs` contains `return`. diff --git a/src/lib_utils/ppx_let_generalized/dune b/src/lib_utils/ppx_let_generalized/dune deleted file mode 100644 index e69de29bb..000000000 diff --git a/src/lib_utils/ppx_let_generalized/expander/dune b/src/lib_utils/ppx_let_generalized/expander/dune deleted file mode 100644 index 3a9bb1bc8..000000000 --- a/src/lib_utils/ppx_let_generalized/expander/dune +++ /dev/null @@ -1,2 +0,0 @@ -(library (name ppx_let_expander) (public_name tezos-utils.ppx_let_generalized.expander) - (libraries base ppxlib) (preprocess no_preprocessing)) diff --git a/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.ml b/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.ml deleted file mode 100644 index 9a41e63c4..000000000 --- a/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.ml +++ /dev/null @@ -1,155 +0,0 @@ -open Base -open Ppxlib -open Ast_builder.Default - -module List = struct - include List - - let reduce_exn l ~f = - match l with - | [] -> invalid_arg "List.reduce_exn" - | hd :: tl -> fold_left tl ~init:hd ~f - ;; -end - -let let_syntax ~modul : Longident.t = - match modul with - | None -> Lident "Let_syntax" - | Some id -> Ldot (id.txt, "Let_syntax") -;; - -let open_on_rhs ~loc ~modul ~extension_name_s = - Located.mk ~loc (Longident.Ldot (let_syntax ~modul, "Open_on_rhs_" ^ extension_name_s)) -;; - -let eoperator ~loc ~modul func = - let lid : Longident.t = Ldot (let_syntax ~modul, func) in - pexp_ident ~loc (Located.mk ~loc lid) -;; - -let expand_with_tmp_vars ~loc bindings expr ~f = - match bindings with - | [ _ ] -> f ~loc bindings expr - | _ -> - let tmp_vars = - List.map bindings ~f:(fun _ -> gen_symbol ~prefix:"__let_syntax" ()) - in - let s_rhs_tmp_var (* s/rhs/tmp_var *) = - List.map2_exn bindings tmp_vars ~f:(fun vb var -> - { vb with pvb_expr = evar ~loc:vb.pvb_expr.pexp_loc var }) - in - let s_lhs_tmp_var (* s/lhs/tmp_var *) = - List.map2_exn bindings tmp_vars ~f:(fun vb var -> - { vb with pvb_pat = pvar ~loc:vb.pvb_pat.ppat_loc var }) - in - pexp_let ~loc Nonrecursive s_lhs_tmp_var (f ~loc s_rhs_tmp_var expr) -;; - -let bind_apply ~loc ~modul extension_name_s ~arg ~fn = - pexp_apply - ~loc - (eoperator ~loc ~modul extension_name_s) - [ Nolabel, arg; Labelled "f", fn ] -;; - -(* Change by Georges: Always open for all extension names. *) -let maybe_open ~to_open:module_to_open expr = - let loc = expr.pexp_loc in - pexp_open ~loc Override (module_to_open ~loc) expr -;; - -let expand_let extension_name_s ~loc ~modul bindings body = - if List.is_empty bindings - then invalid_arg "expand_let: list of bindings must be non-empty"; - (* Build expression [both E1 (both E2 (both ...))] *) - let nested_boths = - let rev_boths = List.rev_map bindings ~f:(fun vb -> vb.pvb_expr) in - List.reduce_exn rev_boths ~f:(fun acc e -> - let loc = e.pexp_loc in - eapply ~loc (eoperator ~loc ~modul "both") [ e; acc ]) - in - (* Build pattern [(P1, (P2, ...))] *) - let nested_patterns = - let rev_patts = List.rev_map bindings ~f:(fun vb -> vb.pvb_pat) in - List.reduce_exn rev_patts ~f:(fun acc p -> - let loc = p.ppat_loc in - ppat_tuple ~loc [ p; acc ]) - in - bind_apply - ~loc - ~modul - extension_name_s - ~arg:nested_boths - ~fn:(pexp_fun ~loc Nolabel None nested_patterns body) -;; - -let expand_match extension_name_s ~loc ~modul expr cases = - bind_apply - ~loc - ~modul - extension_name_s - ~arg:(maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) expr) - ~fn:(pexp_function ~loc cases) -;; - -let expand_if extension_name ~loc expr then_ else_ = - expand_match - extension_name - ~loc - expr - [ case ~lhs:(pbool ~loc true) ~guard:None ~rhs:then_ - ; case ~lhs:(pbool ~loc false) ~guard:None ~rhs:else_ - ] -;; - -let expand ~modul extension_name_s expr = - let loc = expr.pexp_loc in - let expansion = - match expr.pexp_desc with - | Pexp_let (Nonrecursive, bindings, expr) -> - let bindings = - List.map bindings ~f:(fun vb -> - let pvb_pat = - (* Temporary hack tentatively detecting that the parser - has expanded `let x : t = e` into `let x : t = (e : t)`. - - For reference, here is the relevant part of the parser: - https://github.com/ocaml/ocaml/blob/4.07/parsing/parser.mly#L1628 *) - match vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc with - | ( Ppat_constraint (p, { ptyp_desc = Ptyp_poly ([], t1); _ }) - , Pexp_constraint (_, t2) ) - when phys_equal t1 t2 -> p - | _ -> vb.pvb_pat - in - { vb with - pvb_pat - ; pvb_expr = - maybe_open ~to_open:(open_on_rhs ~modul ~extension_name_s) vb.pvb_expr - }) - in - expand_with_tmp_vars ~loc bindings expr ~f:(expand_let extension_name_s ~modul) - | Pexp_let (Recursive, _, _) -> - Location.raise_errorf - ~loc - "'let%%%s' may not be recursive" - extension_name_s - | Pexp_match (expr, cases) -> expand_match extension_name_s ~loc ~modul expr cases - | Pexp_ifthenelse (expr, then_, else_) -> - let else_ = - match else_ with - | Some else_ -> else_ - | None -> - Location.raise_errorf - ~loc - "'if%%%s' must include an else branch" - extension_name_s - in - expand_if extension_name_s ~loc ~modul expr then_ else_ - | _ -> - Location.raise_errorf - ~loc - "'%%%s' can only be used with 'let', 'match', and 'if'" - extension_name_s - in - { expansion with pexp_attributes = expr.pexp_attributes @ expansion.pexp_attributes } -;; diff --git a/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.mli b/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.mli deleted file mode 100644 index be89bf69d..000000000 --- a/src/lib_utils/ppx_let_generalized/expander/ppx_let_expander.mli +++ /dev/null @@ -1,3 +0,0 @@ -open Ppxlib - -val expand : modul:longident loc option -> string -> expression -> expression diff --git a/src/lib_utils/ppx_let_generalized/src/dune b/src/lib_utils/ppx_let_generalized/src/dune deleted file mode 100644 index ef1eab216..000000000 --- a/src/lib_utils/ppx_let_generalized/src/dune +++ /dev/null @@ -1,2 +0,0 @@ -(library (name ppx_let) (public_name tezos-utils.ppx_let_generalized) (kind ppx_rewriter) - (libraries ppxlib ppx_let_expander) (preprocess no_preprocessing)) diff --git a/src/lib_utils/ppx_let_generalized/src/ppx_let.ml b/src/lib_utils/ppx_let_generalized/src/ppx_let.ml deleted file mode 100644 index 257c3bb09..000000000 --- a/src/lib_utils/ppx_let_generalized/src/ppx_let.ml +++ /dev/null @@ -1,19 +0,0 @@ -open Ppxlib - -let ext extension_name_s = - Extension.declare_with_path_arg - extension_name_s - Extension.Context.expression - Ast_pattern.(single_expr_payload __) - (fun ~loc:_ ~path:_ ~arg expr -> - Ppx_let_expander.expand extension_name_s ~modul:arg expr) -;; - -let () = - Driver.register_transformation - "let" - ~extensions:(List.map ext [ - "bind"; - "xxx"; - ]) -;; diff --git a/src/lib_utils/ppx_let_generalized/src/ppx_let.mli b/src/lib_utils/ppx_let_generalized/src/ppx_let.mli deleted file mode 100644 index 8b1378917..000000000 --- a/src/lib_utils/ppx_let_generalized/src/ppx_let.mli +++ /dev/null @@ -1 +0,0 @@ - diff --git a/src/lib_utils/ppx_let_generalized/test/dune b/src/lib_utils/ppx_let_generalized/test/dune deleted file mode 100644 index 9d4a7273b..000000000 --- a/src/lib_utils/ppx_let_generalized/test/dune +++ /dev/null @@ -1 +0,0 @@ -(executables (names test) (preprocess (pps ppx_let_generalized))) diff --git a/src/lib_utils/ppx_let_generalized/test/test-locations.mlt b/src/lib_utils/ppx_let_generalized/test/test-locations.mlt deleted file mode 100644 index 47a5009e1..000000000 --- a/src/lib_utils/ppx_let_generalized/test/test-locations.mlt +++ /dev/null @@ -1,27 +0,0 @@ -(* -*- tuareg -*- *) - -module Let_syntax = struct - type 'a t = T of 'a - - let map (T x) ~f = T (f x) - let both (T x) (T y) = T (x, y) - - module Open_on_rhs = struct - let return x = T x - let f x ~(doc : string) = T (x, doc) - end -end - -let _ = - [%map_open - let x = return 42 - and y = f 42 in - ()] -;; - -[%%expect - {| -Line _, characters 12-16: -Error: This expression has type doc:string -> (int * string) Let_syntax.t - but an expression was expected of type 'a Let_syntax.t -|}] diff --git a/src/lib_utils/ppx_let_generalized/test/test.ml b/src/lib_utils/ppx_let_generalized/test/test.ml deleted file mode 100644 index d42d663b6..000000000 --- a/src/lib_utils/ppx_let_generalized/test/test.ml +++ /dev/null @@ -1,189 +0,0 @@ -module Monad_example = struct - module Let_syntax = struct - let bind x ~f = f x - module Open_on_rhs_bind = struct - let return _ = "foo" - end - end - - let _mf a = - let%bind xyz = return a in - (int_of_string xyz + 1) - ;; -end - -(* TODO: re-enable some tests *) - -(* -module Monad_example = struct - module X : sig - type 'a t - - module Let_syntax : sig - val return : 'a -> 'a t - - module Let_syntax : sig - val return : 'a -> 'a t - val bind : 'a t -> f:('a -> 'b t) -> 'b t - val map : 'a t -> f:('a -> 'b) -> 'b t - val both : 'a t -> 'b t -> ('a * 'b) t - - module Open_on_rhs : sig - val return : 'a -> 'a t - end - end - end - end = struct - type 'a t = 'a - - let return x = x - let bind x ~f = f x - let map x ~f = f x - let both x y = x, y - - module Let_syntax = struct - let return = return - - module Let_syntax = struct - let return = return - let bind = bind - let map = map - let both = both - - module Open_on_rhs = struct - let return = return - end - end - end - end - - open X.Let_syntax - - let _mf a : _ X.t = - let%bind_open x = a in - return (x + 1) - ;; - - let _mf' a b c : _ X.t = - let%bind_open x = a - and y = b - and u, v = c in - return (x + y + (u * v)) - ;; - - let _mg a : _ X.t = - let%map x : int X.t = a in - x + 1 - ;; - - let _mg' a b c : _ X.t = - let%map x = a - and y = b - and u, v = c in - x + y + (u * v) - ;; - - let _mh a : _ X.t = - match%bind_open a with - | 0 -> return true - | _ -> return false - ;; - - let _mi a : _ X.t = - match%map a with - | 0 -> true - | _ -> false - ;; - - let _mif a : _ X.t = if%bind_open a then return true else return false - let _mif' a : _ X.t = if%map a then true else false -end - -module Applicative_example = struct - module X : sig - type 'a t - - module Let_syntax : sig - val return : 'a -> 'a t - - module Let_syntax : sig - val return : 'a -> 'a t - val map : 'a t -> f:('a -> 'b) -> 'b t - val both : 'a t -> 'b t -> ('a * 'b) t - - module Open_on_rhs : sig - val flag : int t - val anon : int t - end - end - end - end = struct - type 'a t = 'a - - let return x = x - let map x ~f = f x - let both x y = x, y - - module Let_syntax = struct - let return = return - - module Let_syntax = struct - let return = return - let map = map - let both = both - - module Open_on_rhs = struct - let flag = 66 - let anon = 77 - end - end - end - end - - open X.Let_syntax - - (* {[ - let _af a : _ X.t = - let%bind x = a in (* "Error: Unbound value Let_syntax.bind" *) - return (x + 1) - ]} *) - - (* {[ - let _af' a b c : _ X.t = - let%bind x = a and y = b and (u, v) = c in (* "Error: Unbound value Let_syntax.bind" *) - return (x + y + (u * v)) - ]} *) - - let _ag a : _ X.t = - let%map x = a in - x + 1 - ;; - - let _ag' a b c : _ X.t = - let%map x = a - and y = b - and u, v = c in - x + y + (u * v) - ;; - - (* {[ - let _ah a : _ X.t = - match%bind a with (* "Error: Unbound value Let_syntax.bind" *) - | 0 -> return true - | _ -> return false - ]} *) - - let _ai a : _ X.t = - match%map a with - | 0 -> true - | _ -> false - ;; -end - -module Example_without_open = struct - let _ag a : _ Applicative_example.X.t = - let%map.Applicative_example.X.Let_syntax x = a in - x + 1 - ;; -end -*) diff --git a/src/lib_utils/region.ml b/src/lib_utils/region.ml deleted file mode 100644 index 68712727f..000000000 --- a/src/lib_utils/region.ml +++ /dev/null @@ -1,128 +0,0 @@ -(* Regions of a file *) - -let sprintf = Printf.sprintf - -type t = < - start : Pos.t; - stop : Pos.t; - - (* Setters *) - - shift_bytes : int -> t; - shift_one_uchar : int -> t; - set_file : string -> t; - - (* Getters *) - - file : string; - pos : Pos.t * Pos.t; - byte_pos : Lexing.position * Lexing.position; - - (* Predicates *) - - is_ghost : bool; - - (* Conversions to [string] *) - - to_string : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string; - compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string -> - -type region = t - -type 'a reg = {region: t; value: 'a} - -(* Injections *) - -exception Invalid - -let make ~(start: Pos.t) ~(stop: Pos.t) = - if start#file <> stop#file || start#byte_offset > stop#byte_offset - then raise Invalid - else - object - val start = start - method start = start - val stop = stop - method stop = stop - - method shift_bytes len = - let start = start#shift_bytes len - and stop = stop#shift_bytes len - in {< start = start; stop = stop >} - - method shift_one_uchar len = - let start = start#shift_one_uchar len - and stop = stop#shift_one_uchar len - in {< start = start; stop = stop >} - - method set_file name = - let start = start#set_file name - and stop = stop#set_file name - in {< start = start; stop = stop >} - - (* Getters *) - - method file = start#file - method pos = start, stop - method byte_pos = start#byte, stop#byte - - (* Predicates *) - - method is_ghost = start#is_ghost && stop#is_ghost - - (* Conversions to strings *) - - method to_string ?(file=true) ?(offsets=true) mode = - let horizontal = if offsets then "character" else "column" - and start_offset = - if offsets then start#offset mode else start#column mode - and stop_offset = - if offsets then stop#offset mode else stop#column mode in - let info = - if file - then sprintf "in file \"%s\", line %i, %s" - (String.escaped start#file) start#line horizontal - else sprintf "at line %i, %s" start#line horizontal - in if stop#line = start#line - then sprintf "%ss %i-%i" info start_offset stop_offset - else sprintf "%s %i to line %i, %s %i" - info start_offset stop#line horizontal stop_offset - - method compact ?(file=true) ?(offsets=true) mode = - let start_str = start#anonymous ~offsets mode - and stop_str = stop#anonymous ~offsets mode in - if start#file = stop#file then - if file then sprintf "%s:%s-%s" start#file start_str stop_str - else sprintf "%s-%s" start_str stop_str - else sprintf "%s:%s-%s:%s" start#file start_str stop#file stop_str - end - -(* Special regions *) - -let ghost = make ~start:Pos.ghost ~stop:Pos.ghost - -let min = make ~start:Pos.min ~stop:Pos.min - -(* Comparisons *) - -let equal r1 r2 = - r1#file = r2#file -&& Pos.equal r1#start r2#start -&& Pos.equal r1#stop r2#stop - -let lt r1 r2 = - r1#file = r2#file -&& not r1#is_ghost -&& not r2#is_ghost -&& Pos.lt r1#start r2#start -&& Pos.lt r1#stop r2#stop - -let cover r1 r2 = - if r1#is_ghost - then r2 - else if r2#is_ghost - then r1 - else if lt r1 r2 - then make ~start:r1#start ~stop:r2#stop - else make ~start:r2#start ~stop:r1#stop diff --git a/src/lib_utils/region.mli b/src/lib_utils/region.mli deleted file mode 100644 index fb3b8e240..000000000 --- a/src/lib_utils/region.mli +++ /dev/null @@ -1,125 +0,0 @@ -(* Regions of a file - - A _region_ is a contiguous series of bytes, for example, in a text - file. It is here denoted by the object type [t]. - - The start (included) of the region is given by the field [start], - which is a _position_, and the end (excluded) is the position given - by the field [stop]. The convention of including the start and - excluding the end enables to have empty regions if, and only if, - [start = stop]. See module [Pos] for the definition of positions. - - The first byte of a file starts at the offset zero (that is, - column one), and [start] is always lower than or equal to [stop], - and they must refer to the same file. -*) - -type t = < - start : Pos.t; - stop : Pos.t; - - (* Setters *) - - (* The call [region#shift_bytes n] evaluates in a region that is the - translation of region [region] of [n] bytes forward in the - file. The call [region#shift_one_uchar n] is similar, except that - it assumes that [n] is the number of bytes making up one unicode - point. The call [region#set_file f] sets the file name to be - [f]. *) - - shift_bytes : int -> t; - shift_one_uchar : int -> t; - set_file : string -> t; - - (* Getters *) - - (* The method [file] returns the file name. - The method [pos] returns the values of the fields [start] and [stop]. - The method [byte_pos] returns the start and end positions of the - region at hand _interpreting them as lexing positions_, that is, - the unit is the byte. *) - - file : string; - pos : Pos.t * Pos.t; - byte_pos : Lexing.position * Lexing.position; - - (* Predicates *) - - is_ghost : bool; - - (* Conversions to [string] *) - - (* The call [region#to_string ~file ~offsets mode] evaluates in a - string denoting the region [region]. - - The name of the file is present if, and only if, [file = true] or - [file] is missing. - - The positions in the file are expressed horizontal offsets if - [offsets = true] or [offsets] is missing (the default), otherwise - as columns. - - If [mode = `Byte], those positions will be assumed to have bytes - as their unit, otherwise, if [mode = `Point], they will be - assumed to refer to code points. - - The method [compact] has the same signature and calling - convention as [to_string], except that the resulting string is - more compact. - *) - - to_string : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string; - compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string -> - -type region = t - -type 'a reg = {region: t; value: 'a} - -(* Constructors *) - -(* The function [make] creates a region from two positions. If the - positions are not properly ordered or refer to different files, the - exception [Invalid] is raised. *) - -exception Invalid - -val make : start:Pos.t -> stop:Pos.t -> t - -(* Special regions *) - -(* To deal with ghost expressions, that is, pieces of abstract syntax - that have not been built from excerpts of concrete syntax, we need - _ghost regions_. The module [Pos] provides a [ghost] position, and - we also provide a [ghost] region and, in type [t], the method - [is_ghost] to check it. *) - -val ghost : t (* Two [Pos.ghost] positions *) - -(* Occasionnally, we may need a minimum region. It is here made of two - minimal positions. *) - -val min : t (* Two [Pos.min] positions *) - -(* Comparisons *) - -(* Two regions are equal if, and only if, they refer to the same file - and their start positions are equal and their stop positions are - equal. See [Pos.equal]. Note that [r1] and [r2] can be ghosts. *) - -val equal : t -> t -> bool - -(* The call [lt r1 r2] ("lower than") has the value [true] if, and - only if, regions [r1] and [r2] refer to the same file, none is a - ghost and the start position of [r1] is lower than that of - [r2]. (See [Pos.lt].) *) - -val lt : t -> t -> bool - -(* Given two regions [r1] and [r2], we may want the region [cover r1 - r2] that covers [r1] and [r2]. We property [equal (cover r1 r2) - (cover r2 r1)]. (In a sense, it is the maximum region, but we avoid - that name because of the [min] function above.) If [r1] is a ghost, - the cover is [r2], and if [r2] is a ghost, the cover is [r1]. *) - -val cover : t -> t -> t diff --git a/src/lib_utils/tezos-utils.opam b/src/lib_utils/tezos-utils.opam deleted file mode 100644 index 82f9ec13a..000000000 --- a/src/lib_utils/tezos-utils.opam +++ /dev/null @@ -1,54 +0,0 @@ -opam-version: "2.0" -name: "tezos-utils" -version: "1.0" -synopsis: "Tezos Utilities defined in the Tezos repository, to be used by other libraries" -maintainer: "Galfour " -authors: "Galfour " -license: "MIT" -homepage: "https://gitlab.com/gabriel.alfour/tezos" -bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues" -depends: [ - "dune" - "base" - "base" - "bigstring" - "calendar" - "cohttp-lwt-unix" - "cstruct" - "ezjsonm" - "hex" - "hidapi" - "ipaddr" - "irmin" - "js_of_ocaml" - "lwt" - "lwt_log" - "mtime" - "ocplib-endian" - "ocp-ocamlres" - "re" - "rresult" - "stdio" - "uri" - "uutf" - "zarith" - "ocplib-json-typed" - "ocplib-json-typed-bson" - "tezos-crypto" - "tezos-stdlib-unix" - "tezos-data-encoding" - "tezos-protocol-environment" - "tezos-protocol-alpha" - "michelson-parser" - # from ppx_let: - "ocaml" {>= "4.04.2" & < "4.08.0"} - "dune" {build & >= "1.5.1"} - "ppxlib" {>= "0.5.0"} -] -build: [ - ["dune" "build" "-p" name] -] -dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos" -url { - src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.master.tar.gz" -} diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml deleted file mode 100644 index 63dcd2c9d..000000000 --- a/src/lib_utils/tezos_utils.ml +++ /dev/null @@ -1,26 +0,0 @@ -module Stdlib_unix = Tezos_stdlib_unix -module Data_encoding = Tezos_data_encoding -module Crypto = Tezos_crypto -module Signature = Tezos_base.TzPervasives.Signature -module Time = Tezos_base.TzPervasives.Time -module Memory_proto_alpha = X_memory_proto_alpha -module Micheline = X_tezos_micheline - - -module Function = Function -module Error_monad = X_error_monad -module Trace = Trace -module Logger = Logger -module PP_helpers = PP -module Location = Location - -module List = X_list -module Option = X_option -module Cast = Cast -module Tuple = Tuple -module Map = X_map -module Dictionary = Dictionary -module Tree = Tree -module Region = Region -module Pos = Pos - diff --git a/src/lib_utils/trace.ml b/src/lib_utils/trace.ml deleted file mode 100644 index cc51ac242..000000000 --- a/src/lib_utils/trace.ml +++ /dev/null @@ -1,412 +0,0 @@ -module J = Yojson.Basic - -type error = [`Assoc of (string * J.t) list] - -module JSON_string_utils = struct - let member = J.Util.member - let string = J.Util.to_string_option - let int = J.Util.to_int_option - - let swap f l r = f r l - - let unit x = Some x - let bind f = function None -> None | Some x -> Some (f x) - let bind2 f = fun l r -> match l, r with - None, None -> None - | None, Some _ -> None - | Some _, None -> None - | Some l, Some r -> Some (f l r) - - let default d = function - Some x -> x - | None -> d - - let string_of_int = bind string_of_int - - let (||) l r = l |> default r - let (|^) = bind2 (^) -end - -let mk_error ?(error_code : int option) ~(title : string) ?(message : string option) () = - let collapse l = - List.fold_left (fun acc -> function None -> acc | Some e -> e::acc) [] (List.rev l) in - `Assoc - (collapse - [(match error_code with Some c -> Some ("error_code", `Int c) | None -> None); - Some ("title", `String title); - (match message with Some m -> Some ("message", `String m) | None -> None)]) - - -type error_thunk = unit -> error - -type annotation = J.t (* feel free to add different annotations here. *) -type annotation_thunk = unit -> annotation - -type 'a result = - Ok of 'a * annotation_thunk list - | Errors of error_thunk list - -let ok x = Ok (x, []) -let fail err = Errors [err] - -(* When passing a constant string where a thunk is expected, we wrap it with thunk, as follows: - (thunk "some string") - We always put the parentheses around the call, to increase grep and sed efficiency. - - When a trace function is called, it is passed a `(fun () -> …)`. - If the `…` is e.g. error then we write `(fun () -> error title msg ()` *) -let thunk x () = x - -let error title message () = mk_error ~title:(title ()) ~message:(message ()) () - -let simple_error str () = mk_error ~title:str () - -let simple_fail str = fail @@ simple_error str - -(* To be used when wrapped by a "trace_strong" for instance *) -let dummy_fail = simple_fail "dummy" - -let map f = function - | Ok (x, annotations) -> - (match f x with - Ok (x', annotations') -> Ok (x', annotations' @ annotations) - | Errors _ as e' -> ignore annotations; e') - | Errors _ as e -> e - -let apply f = function - | Ok (x, annotations) -> Ok (f x, annotations) - | Errors _ as e -> e - -let (>>?) x f = map f x -let (>>|?) = apply - -module Let_syntax = struct - let bind m ~f = m >>? f - module Open_on_rhs_bind = struct end -end - -let trace_strong err = function - | Ok _ as o -> o - | Errors _ -> Errors [err] - -let trace err = function - | Ok _ as o -> o - | Errors errs -> Errors (err :: errs) - -let trace_r err_thunk_may_fail = function - | Ok _ as o -> o - | Errors errs -> - match err_thunk_may_fail () with - | Ok (err, annotations) -> ignore annotations; Errors (err :: errs) - | Errors errors_while_generating_error -> - (* TODO: the complexity could be O(n*n) in the worst case, - this should use some catenable lists. *) - Errors (errors_while_generating_error - @ errs) - -let trace_f f error x = - trace error @@ f x - -let trace_f_2 f error x y = - trace error @@ f x y - -let trace_f_ez f name = - trace_f f (error (thunk "in function") name) - -let trace_f_2_ez f name = - trace_f_2 f (error (thunk "in function") name) - -let to_bool = function - | Ok _ -> true - | Errors _ -> false - -let to_option = function - | Ok (o, annotations) -> ignore annotations; Some o - | Errors _ -> None - -let trace_option error = function - | None -> fail error - | Some s -> ok s - -let bind_map_option f = function - | None -> ok None - | Some s -> f s >>? fun x -> ok (Some x) - -let rec bind_list = function - | [] -> ok [] - | hd :: tl -> ( - hd >>? fun hd -> - bind_list tl >>? fun tl -> - ok @@ hd :: tl - ) -let bind_ne_list = fun (hd , tl) -> - hd >>? fun hd -> - bind_list tl >>? fun tl -> - ok @@ (hd , tl) - -let bind_smap (s:_ X_map.String.t) = - let open X_map.String in - let aux k v prev = - prev >>? fun prev' -> - v >>? fun v' -> - ok @@ add k v' prev' in - fold aux s (ok empty) - -let bind_fold_smap f init (smap : _ X_map.String.t) = - let aux k v prev = - prev >>? fun prev' -> - f prev' k v - in - X_map.String.fold aux smap init - -let bind_map_smap f smap = bind_smap (X_map.String.map f smap) - -let bind_map_list f lst = bind_list (List.map f lst) -let bind_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result = fun f lst -> bind_ne_list (X_list.Ne.map f lst) -let bind_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst -> - bind_map_list f lst >>? fun _ -> ok () - -let bind_location (x:_ Location.wrap) = - x.wrap_content >>? fun wrap_content -> - ok { x with wrap_content } - -let bind_map_location f x = bind_location (Location.map f x) - -let bind_fold_list f init lst = - let aux x y = - x >>? fun x -> - f x y - in - List.fold_left aux (ok init) lst - -let bind_fold_map_list = fun f acc lst -> - let rec aux (acc , prev) f = function - | [] -> ok (acc , prev) - | hd :: tl -> - f acc hd >>? fun (acc' , hd') -> - aux (acc' , hd' :: prev) f tl - in - aux (acc , []) f lst >>? fun (_acc' , lst') -> - ok @@ List.rev lst' - -let bind_fold_map_right_list = fun f acc lst -> - let rec aux (acc , prev) f = function - | [] -> ok (acc , prev) - | hd :: tl -> - f acc hd >>? fun (acc' , hd') -> - aux (acc' , hd' :: prev) f tl - in - aux (acc , []) f (List.rev lst) >>? fun (_acc' , lst') -> - ok lst' - -let bind_fold_right_list f init lst = - let aux x y = - x >>? fun x -> - f x y - in - X_list.fold_right' aux (ok init) lst - -let bind_find_map_list error f lst = - let rec aux lst = - match lst with - | [] -> fail error - | hd :: tl -> ( - match f hd with - | Errors _ -> aux tl - | o -> o - ) - in - aux lst - -let bind_list_iter f lst = - let aux () y = f y in - bind_fold_list aux () lst - -let bind_or (a, b) = - match a with - | Ok _ as o -> o - | _ -> b - -let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = - match (a, b) with - | (Ok _ as o), _ -> apply (fun x -> `Left x) o - | _, (Ok _ as o) -> apply (fun x -> `Right x) o - | _, Errors b -> Errors b - -let bind_lr_lazy (type a b) ((a : a result), (b:unit -> b result)) : [`Left of a | `Right of b] result = - match a with - | Ok _ as o -> apply (fun x -> `Left x) o - | _ -> ( - match b() with - | Ok _ as o -> apply (fun x -> `Right x) o - | Errors b -> Errors b - ) - -let bind_and (a, b) = - a >>? fun a -> - b >>? fun b -> - ok (a, b) - -let bind_pair = bind_and -let bind_map_pair f (a, b) = - bind_pair (f a, f b) - -module AE = Memory_proto_alpha.Alpha_environment -module TP = Tezos_base__TzPervasives - -let of_tz_error (err:X_error_monad.error) : error_thunk = - let str () = X_error_monad.(to_string err) in - error (thunk "alpha error") str - -let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) - -let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = - function - | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_alpha_tz_error errs) - -let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = - trace_alpha_tzresult error @@ Lwt_main.run x - -let trace_tzresult err = - function - | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_tz_error errs) - -(* TODO: should be a combination of trace_tzresult and trace_r *) -let trace_tzresult_r err_thunk_may_fail = - function - | Result.Ok x -> ok x - | Error errs -> - let tz_errs = List.map of_tz_error errs in - match err_thunk_may_fail () with - | Ok (err, annotations) -> ignore annotations; Errors (err :: tz_errs) - | Errors errors_while_generating_error -> - (* TODO: the complexity could be O(n*n) in the worst case, - this should use some catenable lists. *) - Errors (errors_while_generating_error - @ tz_errs) - -let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = - trace_tzresult err @@ Lwt_main.run x - -let trace_tzresult_lwt_r err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = - trace_tzresult_r err @@ Lwt_main.run x - -let generic_try err f = - try ( - ok @@ f () - ) with _ -> fail err - -let specific_try handler f = - try ( - ok @@ f () - ) with exn -> fail ((handler ()) exn) - -let sys_try f = - let handler () = function - | Sys_error str -> error (thunk "Sys_error") (fun () -> str) - | exn -> raise exn - in - specific_try handler f - -let sys_command command = - sys_try (fun () -> Sys.command command) >>? function - | 0 -> ok () - | n -> fail (fun () -> error (thunk "Nonzero return code") (fun () -> (string_of_int n)) ()) - -let trace_sequence f lst = - let lazy_map_force : 'a . (unit -> 'a) list -> (unit -> 'a list) = fun l -> - fun () -> - List.rev @@ List.rev_map (fun a -> a ()) l in - let rec aux acc_x acc_annotations = function - | hd :: tl -> ( - match f hd with - (* TODO: what should we do with the annotations? *) - | Ok (x, annotations) -> aux (x :: acc_x) (lazy_map_force annotations :: acc_annotations) tl - | Errors _ as errs -> errs - ) - | [] -> - let old_annotations () = List.map (fun a -> `List (a ())) @@ List.rev acc_annotations in - (* Builds a JSON annotation { "type": "list"; "content": [[…], …] } *) - let annotation = fun () -> `Assoc [("type", `String "list"); ("content", `List (old_annotations ()))] - in Ok (List.rev acc_x, [annotation]) in - aux [] lst - -let json_of_error = J.to_string -let error_pp out (e : error) = - let open JSON_string_utils in - let e : J.t = (match e with `Assoc _ as e -> e) in - let message = e |> member "message" |> string in - let title = e |> member "title" |> string || "(no title)" in - let error_code = unit " " |^ (e |> member "error_code" |> int |> string_of_int) || "" in - Format.fprintf out "%s" (error_code ^ ": " ^ title ^ (unit ":" |^ message || "")) - -let error_pp_short out (e : error) = - let open JSON_string_utils in - let e : J.t = (match e with `Assoc _ as e -> e) in - let title = e |> member "title" |> string || "(no title)" in - let error_code = unit " " |^ (e |> member "error_code" |> int |> string_of_int) || "" in - Format.fprintf out "%s" (error_code ^ ": " ^ title) - -let errors_pp = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp - -let errors_pp_short = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp_short - -let pp_to_string pp () x = - Format.fprintf Format.str_formatter "%a" pp x ; - Format.flush_str_formatter () - -let errors_to_string = pp_to_string errors_pp - -module Assert = struct - let assert_fail ?(msg="didn't fail") = function - | Ok _ -> simple_fail msg - | _ -> ok () - - let assert_true ?(msg="not true") = function - | true -> ok () - | false -> simple_fail msg - - let assert_equal ?msg expected actual = - assert_true ?msg (expected = actual) - - let assert_equal_int ?msg expected actual = - let msg = - let default = Format.asprintf "Not equal int : expected %d, got %d" expected actual in - X_option.unopt ~default msg in - assert_equal ~msg expected actual - - let assert_equal_bool ?msg expected actual = - let msg = - let default = Format.asprintf "Not equal bool : expected %b, got %b" expected actual in - X_option.unopt ~default msg in - assert_equal ~msg expected actual - - let assert_none ?(msg="not a none") opt = match opt with - | None -> ok () - | _ -> simple_fail msg - - let assert_list_size ?(msg="lst doesn't have the right size") lst n = - assert_true ~msg List.(length lst = n) - - let assert_list_empty ?(msg="lst isn't empty") lst = - assert_true ~msg List.(length lst = 0) - - let assert_list_same_size ?(msg="lists don't have same size") a b = - assert_true ~msg List.(length a = length b) - - let assert_list_size_2 ~msg = function - | [a;b] -> ok (a, b) - | _ -> simple_fail msg - - let assert_list_size_1 ~msg = function - | [a] -> ok a - | _ -> simple_fail msg -end diff --git a/src/lib_utils/tree.ml b/src/lib_utils/tree.ml deleted file mode 100644 index efa773ada..000000000 --- a/src/lib_utils/tree.ml +++ /dev/null @@ -1,130 +0,0 @@ -[@@@warning "-9"] - -module Append = struct - type 'a t' = - | Leaf of 'a - | Node of { - a : 'a t' ; - b : 'a t' ; - size : int ; - full : bool ; - } - - type 'a t = - | Empty - | Full of 'a t' - - let node (a, b, size, full) = Node {a;b;size;full} - - let rec exists' f = function - | Leaf s' when f s' -> true - | Leaf _ -> false - | Node{a;b} -> exists' f a || exists' f b - let exists f = function - | Empty -> false - | Full x -> exists' f x - - let rec exists_path' f = function - | Leaf x -> if f x then Some [] else None - | Node {a;b} -> ( - match exists_path' f a with - | Some a -> Some (false :: a) - | None -> ( - match exists_path' f b with - | Some b -> Some (true :: b) - | None -> None - ) - ) - - let exists_path f = function - | Empty -> None - | Full x -> exists_path' f x - - let empty : 'a t = Empty - - let size' = function - | Leaf _ -> 1 - | Node {size} -> size - - let size = function - | Empty -> 0 - | Full x -> size' x - - let rec append' x = function - | Leaf e -> node (Leaf e, Leaf x, 1, true) - | Node({full=true;size}) as n -> node(n, Leaf x, size + 1, false) - | Node({a=Node a;b;full=false} as n) -> ( - match append' x b with - | Node{full=false} as b -> Node{n with b} - | Node({full=true} as b) -> Node{n with b = Node b ; full = b.size = a.size} - | Leaf _ -> assert false - ) - | Node{a=Leaf _;full=false} -> assert false - - let append x = function - | Empty -> Full (Leaf x) - | Full t -> Full (append' x t) - - let of_list lst = - let rec aux = function - | [] -> Empty - | hd :: tl -> append hd (aux tl) - in - aux @@ List.rev lst - - let rec to_list' t' = - match t' with - | Leaf x -> [x] - | Node {a;b} -> (to_list' a) @ (to_list' b) - - let to_list t = - match t with - | Empty -> [] - | Full x -> to_list' x - - let rec fold' leaf node = function - | Leaf x -> leaf x - | Node {a;b} -> node (fold' leaf node a) (fold' leaf node b) - - let rec fold_s' : type a b . a -> (a -> b -> a) -> b t' -> a = fun init leaf -> function - | Leaf x -> leaf init x - | Node {a;b} -> fold_s' (fold_s' init leaf a) leaf b - - let fold_ne leaf node = function - | Empty -> raise (Failure "Tree.Append.fold_ne") - | Full x -> fold' leaf node x - - let fold_s_ne : type a b . a -> (a -> b -> a) -> b t -> a = fun init leaf -> function - | Empty -> raise (Failure "Tree.Append.fold_s_ne") - | Full x -> fold_s' init leaf x - - let fold empty leaf node = function - | Empty -> empty - | Full x -> fold' leaf node x - - - let rec assoc_opt' : ('a * 'b) t' -> 'a -> 'b option = fun t k -> - match t with - | Leaf (k', v) when k = k' -> Some v - | Leaf _ -> None - | Node {a;b} -> ( - match assoc_opt' a k with - | None -> assoc_opt' b k - | Some v -> Some v - ) - - let assoc_opt : ('a * 'b) t -> 'a -> 'b option = fun t k -> - match t with - | Empty -> None - | Full t' -> assoc_opt' t' k - - let rec pp' : _ -> _ -> 'a t' -> unit = fun f ppf t' -> - match t' with - | Leaf x -> Format.fprintf ppf "%a" f x - | Node {a;b} -> Format.fprintf ppf "N(%a , %a)" (pp' f) a (pp' f) b - - let pp : _ -> _ -> 'a t -> unit = fun f ppf t -> - match t with - | Empty -> Format.fprintf ppf "[]" - | Full x -> Format.fprintf ppf "[%a]" (pp' f) x -end diff --git a/src/lib_utils/tuple.ml b/src/lib_utils/tuple.ml deleted file mode 100644 index ad451e74d..000000000 --- a/src/lib_utils/tuple.ml +++ /dev/null @@ -1,9 +0,0 @@ -let map_h_2 f g (a , b) = (f a , g b) -let map2 f (a, b) = (f a, f b) -let apply2 f (a, b) = f a b -let list2 (a, b) = [a;b] - -module Pair = struct - let map = map2 - let apply f (a, b) = f a b -end diff --git a/src/lib_utils/wrap.ml b/src/lib_utils/wrap.ml deleted file mode 100644 index 2a9b1eab4..000000000 --- a/src/lib_utils/wrap.ml +++ /dev/null @@ -1,21 +0,0 @@ -module Make (P : sig type meta end) = struct - type meta = P.meta - type 'value t = { - value : 'value ; - meta : meta ; - } - - let make meta value = { value ; meta } - let value t = t.value - let meta t = t.meta - - let apply : ('a -> 'b) -> 'a t -> 'b = fun f x -> f x.value -end - -module Location = struct - include Make(struct type meta = Location.t end) - - let make_f f : loc:_ -> _ -> _ t = fun ~loc x -> make loc (f x) - let make ~loc x : _ t = make loc x - let update_location ~loc t = {t with meta = loc} -end diff --git a/src/lib_utils/x_error_monad.ml b/src/lib_utils/x_error_monad.ml deleted file mode 100644 index ca28344ea..000000000 --- a/src/lib_utils/x_error_monad.ml +++ /dev/null @@ -1,50 +0,0 @@ -module Error_monad = Tezos_error_monad.Error_monad -include Error_monad - -let to_string err = - let json = json_of_error err in - Tezos_data_encoding.Json.to_string json - -let print err = - Format.printf "%s\n" @@ to_string err - -let force_ok ?(msg = "") = function - | Ok x -> x - | Error errs -> - Format.printf "Errors :\n"; - List.iter print errs ; - raise @@ Failure ("force_ok : " ^ msg) - -let is_ok = function - | Ok _ -> true - | Error _ -> false - -let force_ok_str ?(msg = "") = function - | Ok x -> x - | Error err -> - Format.printf "Error : %s\n" err; - raise @@ Failure ("force_ok : " ^ msg) - -open Memory_proto_alpha - -let (>>??) = Alpha_environment.Error_monad.(>>?) - -let alpha_wrap a = Alpha_environment.wrap_error a - -let force_ok_alpha ~msg a = force_ok ~msg @@ alpha_wrap a - -let force_lwt ~msg a = force_ok ~msg @@ Lwt_main.run a - -let force_lwt_alpha ~msg a = force_ok ~msg @@ alpha_wrap @@ Lwt_main.run a - -let assert_error () = function - | Ok _ -> fail @@ failure "assert_error" - | Error _ -> return () - -let (>>=??) a f = - a >>= fun a -> - match alpha_wrap a with - | Ok result -> f result - | Error errs -> Lwt.return (Error errs) - - diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml deleted file mode 100644 index f1986e488..000000000 --- a/src/lib_utils/x_list.ml +++ /dev/null @@ -1,159 +0,0 @@ -include Tezos_base.TzPervasives.List - -let map ?(acc = []) f lst = - let rec aux acc f = function - | [] -> acc - | hd :: tl -> aux (f hd :: acc) f tl - in - aux acc f (List.rev lst) - -let fold_map_right : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list = - fun f acc lst -> - let rec aux (acc , prev) f = function - | [] -> (acc , prev) - | hd :: tl -> - let (acc' , hd') = f acc hd in - aux (acc' , hd' :: prev) f tl - in - snd @@ aux (acc , []) f (List.rev lst) - -let fold_map : type acc ele ret . (acc -> ele -> (acc * ret)) -> acc -> ele list -> ret list = - fun f acc lst -> - let rec aux (acc , prev) f = function - | [] -> (acc , prev) - | hd :: tl -> - let (acc' , hd') = f acc hd in - aux (acc' , hd' :: prev) f tl - in - List.rev @@ snd @@ aux (acc , []) f lst - -let fold_right' f init lst = List.fold_left f init (List.rev lst) - -let rec remove_element x lst = - match lst with - | [] -> raise (Failure "X_list.remove_element") - | hd :: tl when x = hd -> tl - | hd :: tl -> hd :: remove_element x tl - -let filter_map f = - let rec aux acc lst = match lst with - | [] -> List.rev acc - | hd :: tl -> aux ( - match f hd with - | Some x -> x :: acc - | None -> acc - ) tl - in - aux [] - -let cons_iter = fun fhd ftl lst -> - match lst with - | [] -> () - | hd :: tl -> fhd hd ; List.iter ftl tl - -let range n = - let rec aux acc n = - if n = 0 - then acc - else aux ((n-1) :: acc) (n-1) - in - aux [] n - -let find_map f lst = - let rec aux = function - | [] -> None - | hd::tl -> ( - match f hd with - | Some _ as s -> s - | None -> aux tl - ) - in - aux lst - -let find_index f lst = - let rec aux n = function - | [] -> raise (Failure "find_index") - | hd :: _ when f hd -> n - | _ :: tl -> aux (n + 1) tl in - aux 0 lst - -let find_full f lst = - let rec aux n = function - | [] -> raise (Failure "find_index") - | hd :: _ when f hd -> (hd, n) - | _ :: tl -> aux (n + 1) tl in - aux 0 lst - -let assoc_i x lst = - let rec aux n = function - | [] -> raise (Failure "List:assoc_i") - | (x', y) :: _ when x = x' -> (y, n) - | _ :: tl -> aux (n + 1) tl - in - aux 0 lst - -let rec from n lst = - if n = 0 - then lst - else from (n - 1) (tl lst) - -let until n lst = - let rec aux acc n lst = - if n = 0 - then acc - else aux ((hd lst) :: acc) (n - 1) (tl lst) - in - rev (aux [] n lst) - -let uncons_opt = function - | [] -> None - | hd :: tl -> Some (hd, tl) - -let rev_uncons_opt = function - | [] -> None - | lst -> - let r = rev lst in - let last = hd r in - let hds = rev @@ tl r in - Some (hds , last) - -let hds lst = match rev_uncons_opt lst with - | None -> failwith "toto" - | Some (hds , _) -> hds - -let to_pair = function - | [a ; b] -> Some (a , b) - | _ -> None - -let to_singleton = function - | [a] -> Some a - | _ -> None - -module Ne = struct - - type 'a t = 'a * 'a list - - let of_list lst = List.(hd lst, tl lst) - let to_list (hd, tl : _ t) = hd :: tl - let singleton hd : 'a t = hd , [] - let hd : 'a t -> 'a = fst - let cons : 'a -> 'a t -> 'a t = fun hd' (hd , tl) -> hd' , hd :: tl - let iter f (hd, tl : _ t) = f hd ; List.iter f tl - let map f (hd, tl : _ t) = f hd, List.map f tl - let hd_map : _ -> 'a t -> 'a t = fun f (hd , tl) -> (f hd , tl) - let mapi f (hd, tl : _ t) = - let lst = List.mapi f (hd::tl) in - of_list lst - let concat (hd, tl : _ t) = hd @ List.concat tl - let rev (hd, tl : _ t) = - match tl with - | [] -> (hd, []) - | lst -> - let r = List.rev lst in - (List.hd r, List.tl r @ [hd]) - let find_map = fun f (hd , tl : _ t) -> - match f hd with - | Some x -> Some x - | None -> find_map f tl - -end diff --git a/src/lib_utils/x_map.ml b/src/lib_utils/x_map.ml deleted file mode 100644 index ded0b83e2..000000000 --- a/src/lib_utils/x_map.ml +++ /dev/null @@ -1,27 +0,0 @@ -module type OrderedType = Map.OrderedType - -module type S = sig - include Map.S - - val of_list : (key * 'a) list -> 'a t - val to_list : 'a t -> 'a list - val to_kv_list : 'a t -> (key * 'a) list -end - -module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct - include Map.Make(Ord) - - let of_list (lst: (key * 'a) list) : 'a t = - let aux prev (k, v) = add k v prev in - List.fold_left aux empty lst - - let to_list (t: 'a t) : 'a list = - let aux _k v prev = v :: prev in - fold aux t [] - - let to_kv_list (t: 'a t) : (key * 'a) list = - let aux k v prev = (k, v) :: prev in - fold aux t [] -end - -module String = Make(String) diff --git a/src/lib_utils/x_memory_proto_alpha.ml b/src/lib_utils/x_memory_proto_alpha.ml deleted file mode 100644 index 1657f7a16..000000000 --- a/src/lib_utils/x_memory_proto_alpha.ml +++ /dev/null @@ -1,133 +0,0 @@ -module Michelson = X_tezos_micheline.Michelson - -include Memory_proto_alpha -let init_environment = Init_proto_alpha.init_environment -let dummy_environment = Init_proto_alpha.dummy_environment - -open X_error_monad -open Script_typed_ir -open Script_ir_translator -open Script_interpreter - -let stack_ty_eq (type a b) - ?(tezos_context = dummy_environment.tezos_context) - (a:a stack_ty) (b:b stack_ty) = - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> - ok Eq - -let ty_eq (type a b) - ?(tezos_context = dummy_environment.tezos_context) - (a:a ty) (b:b ty) - = - alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> - ok Eq - -let parse_michelson (type aft) - ?(tezos_context = dummy_environment.tezos_context) - ?(top_level = Lambda) (michelson:Michelson.t) - ?type_logger - (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) - = - let michelson = Michelson.strip_annots michelson in - let michelson = Michelson.strip_nops michelson in - parse_instr - ?type_logger - top_level tezos_context - michelson bef >>=?? fun (j, _) -> - match j with - | Typed descr -> ( - Lwt.return ( - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> - let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in - Ok descr - ) - ) - | _ -> Lwt.return @@ error_exn (Failure "Typing instr failed") - -let parse_michelson_fail (type aft) - ?(tezos_context = dummy_environment.tezos_context) - ?(top_level = Lambda) (michelson:Michelson.t) - ?type_logger - (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) - = - let michelson = Michelson.strip_annots michelson in - let michelson = Michelson.strip_nops michelson in - parse_instr - ?type_logger - top_level tezos_context - michelson bef >>=?? fun (j, _) -> - match j with - | Typed descr -> ( - Lwt.return ( - alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> - let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in - Ok descr - ) - ) - | Failed { descr } -> - Lwt.return (Ok (descr aft)) - -let parse_michelson_data - ?(tezos_context = dummy_environment.tezos_context) - michelson ty = - let michelson = Michelson.strip_annots michelson in - let michelson = Michelson.strip_nops michelson in - parse_data tezos_context ty michelson >>=?? fun (data, _) -> - return data - -let parse_michelson_ty - ?(tezos_context = dummy_environment.tezos_context) - ?(allow_big_map = true) ?(allow_operation = true) - michelson = - let michelson = Michelson.strip_annots michelson in - let michelson = Michelson.strip_nops michelson in - Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) -> - return ty - -let unparse_michelson_data - ?(tezos_context = dummy_environment.tezos_context) - ?mapper ty value : Michelson.t tzresult Lwt.t = - Script_ir_translator.unparse_data tezos_context ?mapper - Readable ty value >>=?? fun (michelson, _) -> - return michelson - -let unparse_michelson_ty - ?(tezos_context = dummy_environment.tezos_context) - ty : Michelson.t tzresult Lwt.t = - Script_ir_translator.unparse_ty tezos_context ty >>=?? fun (michelson, _) -> - return michelson - -type options = { - tezos_context: Alpha_context.t ; - source: Alpha_context.Contract.t ; - payer: Alpha_context.Contract.t ; - self: Alpha_context.Contract.t ; - amount: Alpha_context.Tez.t ; -} - -let make_options - ?(tezos_context = dummy_environment.tezos_context) - ?(source = (List.nth dummy_environment.identities 0).implicit_contract) - ?(self = (List.nth dummy_environment.identities 0).implicit_contract) - ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) - ?(amount = Alpha_context.Tez.one) () - = { - tezos_context ; - source ; - self ; - payer ; - amount ; - } - -let default_options = make_options () - -let interpret ?(options = default_options) ?visitor (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = - let { - tezos_context ; - source ; - self ; - payer ; - amount ; - } = options in - Script_interpreter.step tezos_context ~source ~self ~payer ?visitor amount instr bef >>=?? - fun (stack, _) -> return stack diff --git a/src/lib_utils/x_option.ml b/src/lib_utils/x_option.ml deleted file mode 100644 index 5aa636cba..000000000 --- a/src/lib_utils/x_option.ml +++ /dev/null @@ -1,39 +0,0 @@ -include Tezos_stdlib.Option - -let lr (a , b) = match (a , b) with - | Some x , _ -> Some (`Left x) - | None , Some x -> Some (`Right x) - | _ -> None - -(* TODO: recursive terminal *) -let rec bind_list = fun lst -> - match lst with - | [] -> Some [] - | hd :: tl -> ( - match hd with - | None -> None - | Some hd' -> ( - match bind_list tl with - | None -> None - | Some tl' -> Some (hd' :: tl') - ) - ) - -let bind_pair = fun (a , b) -> - a >>= fun a' -> - b >>= fun b' -> - Some (a' , b') - -let bind_map_list = fun f lst -> bind_list (X_list.map f lst) - -let bind_map_pair = fun f (a , b) -> bind_pair (f a , f b) - -let bind_smap (s:_ X_map.String.t) = - let open X_map.String in - let aux k v prev = - prev >>= fun prev' -> - v >>= fun v' -> - Some (add k v' prev') in - fold aux s (Some empty) - -let bind_map_smap f smap = bind_smap (X_map.String.map f smap) diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml deleted file mode 100644 index 61c8660bc..000000000 --- a/src/lib_utils/x_tezos_micheline.ml +++ /dev/null @@ -1,95 +0,0 @@ -include Tezos_micheline - -module Michelson = struct - open Micheline - include Memory_proto_alpha.Michelson_v1_primitives - - type michelson = (int, prim) node - type t = michelson - - let prim ?(annot=[]) ?(children=[]) p : michelson = - Prim (0, p, children, annot) - - let annotate annot = function - | Prim (l, p, c, []) -> Prim (l, p, c, [annot]) - | _ -> raise (Failure "annotate") - - let seq s : michelson = Seq (0, s) - - let i_comment s : michelson = prim ~annot:["\"" ^ s ^ "\""] I_NOP - - let contract parameter storage code = - seq [ - prim ~children:[parameter] K_parameter ; - prim ~children:[storage] K_storage ; - prim ~children:[code] K_code ; - ] - - let int n : michelson = Int (0, n) - let string s : michelson = String (0, s) - let bytes s : michelson = Bytes (0, s) - - let t_unit = prim T_unit - let t_string = prim T_string - let t_pair a b = prim ~children:[a;b] T_pair - let t_lambda a b = prim ~children:[a;b] T_lambda - - let d_unit = prim D_Unit - let d_pair a b = prim ~children:[a;b] D_Pair - - let i_dup = prim I_DUP - let i_car = prim I_CAR - let i_cdr = prim I_CDR - let i_pair = prim I_PAIR - let i_swap = prim I_SWAP - let i_piar = seq [ i_swap ; i_pair ] - let i_push ty code = prim ~children:[ty;code] I_PUSH - let i_push_unit = i_push t_unit d_unit - let i_push_string str = i_push t_string (string str) - let i_none ty = prim ~children:[ty] I_NONE - let i_nil ty = prim ~children:[ty] I_NIL - let i_some = prim I_SOME - let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA - let i_empty_map src dst = prim ~children:[src;dst] I_EMPTY_MAP - let i_drop = prim I_DROP - let i_exec = prim I_EXEC - - let i_if a b = prim ~children:[seq [a] ; seq[b]] I_IF - let i_if_none a b = prim ~children:[seq [a] ; seq[b]] I_IF_NONE - let i_if_left a b = prim ~children:[seq [a] ; seq[b]] I_IF_LEFT - let i_failwith = prim I_FAILWITH - let i_assert_some = i_if_none (seq [i_push_string "ASSERT_SOME" ; i_failwith]) (seq []) - let i_assert_some_msg msg = i_if_none (seq [msg ; i_failwith]) (seq []) - - let dip code : michelson = prim ~children:[seq [code]] I_DIP - let i_unpair = seq [i_dup ; i_car ; dip i_cdr] - let i_unpiar = seq [i_dup ; i_cdr ; dip i_car] - - let rec strip_annots : michelson -> michelson = function - | Seq(l, s) -> Seq(l, List.map strip_annots s) - | Prim (l, p, lst, _) -> Prim (l, p, List.map strip_annots lst, []) - | x -> x - - let rec strip_nops : michelson -> michelson = function - | Seq(l, s) -> Seq(l, List.map strip_nops s) - | Prim (l, I_NOP, _, _) -> Seq (l, []) - | Prim (l, p, lst, a) -> Prim (l, p, List.map strip_nops lst, a) - | x -> x - - let pp ppf (michelson:michelson) = - let open Micheline_printer in - let canonical = strip_locations michelson in - let node = printable string_of_prim canonical in - print_expr ppf node - - let pp_stripped ppf (michelson:michelson) = - let open Micheline_printer in - let michelson' = strip_nops @@ strip_annots michelson in - let canonical = strip_locations michelson' in - let node = printable string_of_prim canonical in - print_expr ppf node - - let pp_naked ppf m = - let naked = strip_annots m in - pp ppf naked -end diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index 34933a848..ce3617329 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -185,7 +185,7 @@ end module Script : sig - type prim = Michelson_v1_primitives.prim = + type prim = Micheline.Michelson_primitives.prim = | K_parameter | K_storage | K_code @@ -300,6 +300,7 @@ module Script : sig | T_operation | T_address + type location = Micheline.canonical_location type annot = Micheline.annot diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml index bfd885fff..da4da1aa7 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.ml @@ -25,576 +25,20 @@ open Micheline -type error += Unknown_primitive_name of string -type error += Invalid_case of string -type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location +include Michelson_primitives -type prim = - | K_parameter - | K_storage - | K_code - | D_False - | D_Elt - | D_Left - | D_None - | D_Pair - | D_Right - | D_Some - | D_True - | D_Unit - | I_PACK - | I_UNPACK - | I_BLAKE2B - | I_SHA256 - | I_SHA512 - | I_ABS - | I_ADD - | I_AMOUNT - | I_AND - | I_BALANCE - | I_CAR - | I_CDR - | I_CHECK_SIGNATURE - | I_COMPARE - | I_CONCAT - | I_CONS - | I_CREATE_ACCOUNT - | I_CREATE_CONTRACT - | I_IMPLICIT_ACCOUNT - | I_DIP - | I_DROP - | I_DUP - | I_EDIV - | I_EMPTY_MAP - | I_EMPTY_SET - | I_EQ - | I_EXEC - | I_FAILWITH - | I_GE - | I_GET - | I_GT - | I_HASH_KEY - | I_IF - | I_IF_CONS - | I_IF_LEFT - | I_IF_NONE - | I_INT - | I_LAMBDA - | I_LE - | I_LEFT - | I_LOOP - | I_LSL - | I_LSR - | I_LT - | I_MAP - | I_MEM - | I_MUL - | I_NEG - | I_NEQ - | I_NIL - | I_NONE - | I_NOP - | I_NOT - | I_NOW - | I_OR - | I_PAIR - | I_PUSH - | I_RIGHT - | I_SIZE - | I_SOME - | I_SOURCE - | I_SENDER - | I_SELF - | I_SLICE - | I_STEPS_TO_QUOTA - | I_SUB - | I_SWAP - | I_TRANSFER_TOKENS - | I_SET_DELEGATE - | I_UNIT - | I_UPDATE - | I_XOR - | I_ITER - | I_LOOP_LEFT - | I_ADDRESS - | I_CONTRACT - | I_ISNAT - | I_CAST - | I_RENAME - | T_bool - | T_contract - | T_int - | T_key - | T_key_hash - | T_lambda - | T_list - | T_map - | T_big_map - | T_nat - | T_option - | T_or - | T_pair - | T_set - | T_signature - | T_string - | T_bytes - | T_mutez - | T_timestamp - | T_unit - | T_operation - | T_address +type error += Unknown_primitive_name of string (* `Permanent *) +type error += Invalid_case of string (* `Permanent *) +type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *) -let valid_case name = - let is_lower = function '_' | 'a'..'z' -> true | _ -> false in - let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in - let rec for_all a b f = - Compare.Int.(a > b) || f a && for_all (a + 1) b f in - let len = String.length name in - Compare.Int.(len <> 0) - && - Compare.Char.(String.get name 0 <> '_') - && - ((is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_upper (String.get name i))) - || - (is_upper (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i))) - || - (is_lower (String.get name 0) - && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))) +let prim_of_string x = match prim_of_string x with + | Ok x -> ok x + | Error (Unknown_primitive_name x) -> error (Unknown_primitive_name x) + | Error (Invalid_case x) -> error (Invalid_case x) + | Error (Invalid_primitive_name (a , b)) -> error (Invalid_primitive_name (a , b)) -let string_of_prim = function - | K_parameter -> "parameter" - | K_storage -> "storage" - | K_code -> "code" - | D_False -> "False" - | D_Elt -> "Elt" - | D_Left -> "Left" - | D_None -> "None" - | D_Pair -> "Pair" - | D_Right -> "Right" - | D_Some -> "Some" - | D_True -> "True" - | D_Unit -> "Unit" - | I_PACK -> "PACK" - | I_UNPACK -> "UNPACK" - | I_BLAKE2B -> "BLAKE2B" - | I_SHA256 -> "SHA256" - | I_SHA512 -> "SHA512" - | I_ABS -> "ABS" - | I_ADD -> "ADD" - | I_AMOUNT -> "AMOUNT" - | I_AND -> "AND" - | I_BALANCE -> "BALANCE" - | I_CAR -> "CAR" - | I_CDR -> "CDR" - | I_CHECK_SIGNATURE -> "CHECK_SIGNATURE" - | I_COMPARE -> "COMPARE" - | I_CONCAT -> "CONCAT" - | I_CONS -> "CONS" - | I_CREATE_ACCOUNT -> "CREATE_ACCOUNT" - | I_CREATE_CONTRACT -> "CREATE_CONTRACT" - | I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT" - | I_DIP -> "DIP" - | I_DROP -> "DROP" - | I_DUP -> "DUP" - | I_EDIV -> "EDIV" - | I_EMPTY_MAP -> "EMPTY_MAP" - | I_EMPTY_SET -> "EMPTY_SET" - | I_EQ -> "EQ" - | I_EXEC -> "EXEC" - | I_FAILWITH -> "FAILWITH" - | I_GE -> "GE" - | I_GET -> "GET" - | I_GT -> "GT" - | I_HASH_KEY -> "HASH_KEY" - | I_IF -> "IF" - | I_IF_CONS -> "IF_CONS" - | I_IF_LEFT -> "IF_LEFT" - | I_IF_NONE -> "IF_NONE" - | I_INT -> "INT" - | I_LAMBDA -> "LAMBDA" - | I_LE -> "LE" - | I_LEFT -> "LEFT" - | I_LOOP -> "LOOP" - | I_LSL -> "LSL" - | I_LSR -> "LSR" - | I_LT -> "LT" - | I_MAP -> "MAP" - | I_MEM -> "MEM" - | I_MUL -> "MUL" - | I_NEG -> "NEG" - | I_NEQ -> "NEQ" - | I_NIL -> "NIL" - | I_NONE -> "NONE" - | I_NOP -> "NOP" - | I_NOT -> "NOT" - | I_NOW -> "NOW" - | I_OR -> "OR" - | I_PAIR -> "PAIR" - | I_PUSH -> "PUSH" - | I_RIGHT -> "RIGHT" - | I_SIZE -> "SIZE" - | I_SOME -> "SOME" - | I_SOURCE -> "SOURCE" - | I_SENDER -> "SENDER" - | I_SELF -> "SELF" - | I_SLICE -> "SLICE" - | I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA" - | I_SUB -> "SUB" - | I_SWAP -> "SWAP" - | I_TRANSFER_TOKENS -> "TRANSFER_TOKENS" - | I_SET_DELEGATE -> "SET_DELEGATE" - | I_UNIT -> "UNIT" - | I_UPDATE -> "UPDATE" - | I_XOR -> "XOR" - | I_ITER -> "ITER" - | I_LOOP_LEFT -> "LOOP_LEFT" - | I_ADDRESS -> "ADDRESS" - | I_CONTRACT -> "CONTRACT" - | I_ISNAT -> "ISNAT" - | I_CAST -> "CAST" - | I_RENAME -> "RENAME" - | T_bool -> "bool" - | T_contract -> "contract" - | T_int -> "int" - | T_key -> "key" - | T_key_hash -> "key_hash" - | T_lambda -> "lambda" - | T_list -> "list" - | T_map -> "map" - | T_big_map -> "big_map" - | T_nat -> "nat" - | T_option -> "option" - | T_or -> "or" - | T_pair -> "pair" - | T_set -> "set" - | T_signature -> "signature" - | T_string -> "string" - | T_bytes -> "bytes" - | T_mutez -> "mutez" - | T_timestamp -> "timestamp" - | T_unit -> "unit" - | T_operation -> "operation" - | T_address -> "address" - -let prim_of_string = function - | "parameter" -> ok K_parameter - | "storage" -> ok K_storage - | "code" -> ok K_code - | "False" -> ok D_False - | "Elt" -> ok D_Elt - | "Left" -> ok D_Left - | "None" -> ok D_None - | "Pair" -> ok D_Pair - | "Right" -> ok D_Right - | "Some" -> ok D_Some - | "True" -> ok D_True - | "Unit" -> ok D_Unit - | "PACK" -> ok I_PACK - | "UNPACK" -> ok I_UNPACK - | "BLAKE2B" -> ok I_BLAKE2B - | "SHA256" -> ok I_SHA256 - | "SHA512" -> ok I_SHA512 - | "ABS" -> ok I_ABS - | "ADD" -> ok I_ADD - | "AMOUNT" -> ok I_AMOUNT - | "AND" -> ok I_AND - | "BALANCE" -> ok I_BALANCE - | "CAR" -> ok I_CAR - | "CDR" -> ok I_CDR - | "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE - | "COMPARE" -> ok I_COMPARE - | "CONCAT" -> ok I_CONCAT - | "CONS" -> ok I_CONS - | "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT - | "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT - | "IMPLICIT_ACCOUNT" -> ok I_IMPLICIT_ACCOUNT - | "DIP" -> ok I_DIP - | "DROP" -> ok I_DROP - | "DUP" -> ok I_DUP - | "EDIV" -> ok I_EDIV - | "EMPTY_MAP" -> ok I_EMPTY_MAP - | "EMPTY_SET" -> ok I_EMPTY_SET - | "EQ" -> ok I_EQ - | "EXEC" -> ok I_EXEC - | "FAILWITH" -> ok I_FAILWITH - | "GE" -> ok I_GE - | "GET" -> ok I_GET - | "GT" -> ok I_GT - | "HASH_KEY" -> ok I_HASH_KEY - | "IF" -> ok I_IF - | "IF_CONS" -> ok I_IF_CONS - | "IF_LEFT" -> ok I_IF_LEFT - | "IF_NONE" -> ok I_IF_NONE - | "INT" -> ok I_INT - | "LAMBDA" -> ok I_LAMBDA - | "LE" -> ok I_LE - | "LEFT" -> ok I_LEFT - | "LOOP" -> ok I_LOOP - | "LSL" -> ok I_LSL - | "LSR" -> ok I_LSR - | "LT" -> ok I_LT - | "MAP" -> ok I_MAP - | "MEM" -> ok I_MEM - | "MUL" -> ok I_MUL - | "NEG" -> ok I_NEG - | "NEQ" -> ok I_NEQ - | "NIL" -> ok I_NIL - | "NONE" -> ok I_NONE - | "NOP" -> ok I_NOP - | "NOT" -> ok I_NOT - | "NOW" -> ok I_NOW - | "OR" -> ok I_OR - | "PAIR" -> ok I_PAIR - | "PUSH" -> ok I_PUSH - | "RIGHT" -> ok I_RIGHT - | "SIZE" -> ok I_SIZE - | "SOME" -> ok I_SOME - | "SOURCE" -> ok I_SOURCE - | "SENDER" -> ok I_SENDER - | "SELF" -> ok I_SELF - | "SLICE" -> ok I_SLICE - | "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA - | "SUB" -> ok I_SUB - | "SWAP" -> ok I_SWAP - | "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS - | "SET_DELEGATE" -> ok I_SET_DELEGATE - | "UNIT" -> ok I_UNIT - | "UPDATE" -> ok I_UPDATE - | "XOR" -> ok I_XOR - | "ITER" -> ok I_ITER - | "LOOP_LEFT" -> ok I_LOOP_LEFT - | "ADDRESS" -> ok I_ADDRESS - | "CONTRACT" -> ok I_CONTRACT - | "ISNAT" -> ok I_ISNAT - | "CAST" -> ok I_CAST - | "RENAME" -> ok I_RENAME - | "bool" -> ok T_bool - | "contract" -> ok T_contract - | "int" -> ok T_int - | "key" -> ok T_key - | "key_hash" -> ok T_key_hash - | "lambda" -> ok T_lambda - | "list" -> ok T_list - | "map" -> ok T_map - | "big_map" -> ok T_big_map - | "nat" -> ok T_nat - | "option" -> ok T_option - | "or" -> ok T_or - | "pair" -> ok T_pair - | "set" -> ok T_set - | "signature" -> ok T_signature - | "string" -> ok T_string - | "bytes" -> ok T_bytes - | "mutez" -> ok T_mutez - | "timestamp" -> ok T_timestamp - | "unit" -> ok T_unit - | "operation" -> ok T_operation - | "address" -> ok T_address - | n -> - if valid_case n then - error (Unknown_primitive_name n) - else - error (Invalid_case n) - -let prims_of_strings expr = - let rec convert = function - | Int _ | String _ | Bytes _ as expr -> ok expr - | Prim (loc, prim, args, annot) -> - Error_monad.record_trace - (Invalid_primitive_name (expr, loc)) - (prim_of_string prim) >>? fun prim -> - List.fold_left - (fun acc arg -> - acc >>? fun args -> - convert arg >>? fun arg -> - ok (arg :: args)) - (ok []) args >>? fun args -> - ok (Prim (0, prim, List.rev args, annot)) - | Seq (_, args) -> - List.fold_left - (fun acc arg -> - acc >>? fun args -> - convert arg >>? fun arg -> - ok (arg :: args)) - (ok []) args >>? fun args -> - ok (Seq (0, List.rev args)) in - convert (root expr) >>? fun expr -> - ok (strip_locations expr) - -let strings_of_prims expr = - let rec convert = function - | Int _ | String _ | Bytes _ as expr -> expr - | Prim (_, prim, args, annot) -> - let prim = string_of_prim prim in - let args = List.map convert args in - Prim (0, prim, args, annot) - | Seq (_, args) -> - let args = List.map convert args in - Seq (0, args) in - strip_locations (convert (root expr)) - -let prim_encoding = - let open Data_encoding in - def "michelson.v1.primitives" @@ - string_enum [ - ("parameter", K_parameter) ; - ("storage", K_storage) ; - ("code", K_code) ; - ("False", D_False) ; - ("Elt", D_Elt) ; - ("Left", D_Left) ; - ("None", D_None) ; - ("Pair", D_Pair) ; - ("Right", D_Right) ; - ("Some", D_Some) ; - ("True", D_True) ; - ("Unit", D_Unit) ; - ("PACK", I_PACK) ; - ("UNPACK", I_UNPACK) ; - ("BLAKE2B", I_BLAKE2B) ; - ("SHA256", I_SHA256) ; - ("SHA512", I_SHA512) ; - ("ABS", I_ABS) ; - ("ADD", I_ADD) ; - ("AMOUNT", I_AMOUNT) ; - ("AND", I_AND) ; - ("BALANCE", I_BALANCE) ; - ("CAR", I_CAR) ; - ("CDR", I_CDR) ; - ("CHECK_SIGNATURE", I_CHECK_SIGNATURE) ; - ("COMPARE", I_COMPARE) ; - ("CONCAT", I_CONCAT) ; - ("CONS", I_CONS) ; - ("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ; - ("CREATE_CONTRACT", I_CREATE_CONTRACT) ; - ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ; - ("DIP", I_DIP) ; - ("DROP", I_DROP) ; - ("DUP", I_DUP) ; - ("EDIV", I_EDIV) ; - ("EMPTY_MAP", I_EMPTY_MAP) ; - ("EMPTY_SET", I_EMPTY_SET) ; - ("EQ", I_EQ) ; - ("EXEC", I_EXEC) ; - ("FAILWITH", I_FAILWITH) ; - ("GE", I_GE) ; - ("GET", I_GET) ; - ("GT", I_GT) ; - ("HASH_KEY", I_HASH_KEY) ; - ("IF", I_IF) ; - ("IF_CONS", I_IF_CONS) ; - ("IF_LEFT", I_IF_LEFT) ; - ("IF_NONE", I_IF_NONE) ; - ("INT", I_INT) ; - ("LAMBDA", I_LAMBDA) ; - ("LE", I_LE) ; - ("LEFT", I_LEFT) ; - ("LOOP", I_LOOP) ; - ("LSL", I_LSL) ; - ("LSR", I_LSR) ; - ("LT", I_LT) ; - ("MAP", I_MAP) ; - ("MEM", I_MEM) ; - ("MUL", I_MUL) ; - ("NEG", I_NEG) ; - ("NEQ", I_NEQ) ; - ("NIL", I_NIL) ; - ("NONE", I_NONE) ; - ("NOT", I_NOT) ; - ("NOW", I_NOW) ; - ("OR", I_OR) ; - ("PAIR", I_PAIR) ; - ("PUSH", I_PUSH) ; - ("RIGHT", I_RIGHT) ; - ("SIZE", I_SIZE) ; - ("SOME", I_SOME) ; - ("SOURCE", I_SOURCE) ; - ("SENDER", I_SENDER) ; - ("SELF", I_SELF) ; - ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ; - ("SUB", I_SUB) ; - ("SWAP", I_SWAP) ; - ("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ; - ("SET_DELEGATE", I_SET_DELEGATE) ; - ("UNIT", I_UNIT) ; - ("UPDATE", I_UPDATE) ; - ("XOR", I_XOR) ; - ("ITER", I_ITER) ; - ("LOOP_LEFT", I_LOOP_LEFT) ; - ("ADDRESS", I_ADDRESS) ; - ("CONTRACT", I_CONTRACT) ; - ("ISNAT", I_ISNAT) ; - ("CAST", I_CAST) ; - ("RENAME", I_RENAME) ; - ("bool", T_bool) ; - ("contract", T_contract) ; - ("int", T_int) ; - ("key", T_key) ; - ("key_hash", T_key_hash) ; - ("lambda", T_lambda) ; - ("list", T_list) ; - ("map", T_map) ; - ("big_map", T_big_map) ; - ("nat", T_nat) ; - ("option", T_option) ; - ("or", T_or) ; - ("pair", T_pair) ; - ("set", T_set) ; - ("signature", T_signature) ; - ("string", T_string) ; - ("bytes", T_bytes) ; - ("mutez", T_mutez) ; - ("timestamp", T_timestamp) ; - ("unit", T_unit) ; - ("operation", T_operation) ; - ("address", T_address) ; - (* Alpha_002 addition *) - ("SLICE", I_SLICE) ; - ] - -let () = - register_error_kind - `Permanent - ~id:"unknownPrimitiveNameTypeError" - ~title: "Unknown primitive name (typechecking error)" - ~description: - "In a script or data expression, a primitive was unknown." - ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n) - Data_encoding.(obj1 (req "wrongPrimitiveName" string)) - (function - | Unknown_primitive_name got -> Some got - | _ -> None) - (fun got -> - Unknown_primitive_name got) ; - register_error_kind - `Permanent - ~id:"invalidPrimitiveNameCaseTypeError" - ~title: "Invalid primitive name case (typechecking error)" - ~description: - "In a script or data expression, a primitive name is \ - neither uppercase, lowercase or capitalized." - ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n) - Data_encoding.(obj1 (req "wrongPrimitiveName" string)) - (function - | Invalid_case name -> Some name - | _ -> None) - (fun name -> - Invalid_case name) ; - register_error_kind - `Permanent - ~id:"invalidPrimitiveNameTypeErro" - ~title: "Invalid primitive name (typechecking error)" - ~description: - "In a script or data expression, a primitive name is \ - unknown or has a wrong case." - ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.") - Data_encoding.(obj2 - (req "expression" (Micheline.canonical_encoding ~variant:"generic" string)) - (req "location" Micheline.canonical_location_encoding)) - (function - | Invalid_primitive_name (expr, loc) -> Some (expr, loc) - | _ -> None) - (fun (expr, loc) -> - Invalid_primitive_name (expr, loc)) +let prims_of_strings x = match prims_of_strings x with + | Ok x -> ok x + | Error (Unknown_primitive_name x) -> error (Unknown_primitive_name x) + | Error (Invalid_case x) -> error (Invalid_case x) + | Error (Invalid_primitive_name (a , b)) -> error (Invalid_primitive_name (a , b)) diff --git a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli index 6b402d8a9..de5abfb5b 100644 --- a/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli +++ b/src/proto_alpha/lib_protocol/michelson_v1_primitives.mli @@ -27,7 +27,7 @@ type error += Unknown_primitive_name of string (* `Permanent *) type error += Invalid_case of string (* `Permanent *) type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location (* `Permanent *) -type prim = +type prim = Micheline.Michelson_primitives.prim = | K_parameter | K_storage | K_code