add ligo-helpers

moved helpers

modified ligo-helpers opam

src/lib_ligo/src/helpers/.gitignore

@@ -0,0 +1,6 @@
+_build/*
+*/_build
+*~
+.merlin
+*/.merlin
+*.install

src/lib_ligo/src/helpers/dictionary.ml

@@ -0,0 +1,33 @@
+open Trace
+
+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 =
+    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 =
+    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

src/lib_ligo/src/helpers/dictionary.mli

@@ -0,0 +1,16 @@
+open Trace
+
+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

src/lib_ligo/src/helpers/dune

@@ -0,0 +1,8 @@
+(library
+  (libraries
+    tezos-base
+    tezos-utils
+  )
+  (name ligo_helpers)
+  (public_name ligo-helpers)
+)

src/lib_ligo/src/helpers/environment.ml

@@ -0,0 +1,53 @@
+module type PARAMETER = sig
+  type key
+  type value
+  val key_cmp : key -> key -> int
+  val value_cmp : value -> value -> int
+end
+
+let parameter (type key value) ?key_cmp ?value_cmp () : (module PARAMETER with type key = key and type value = value) =
+  (module struct
+    type nonrec key = key
+    type nonrec value = value
+    let key_cmp = Option.unopt ~default:compare key_cmp
+    let value_cmp = Option.unopt ~default:compare value_cmp
+  end)
+
+let int_parameter = (parameter () : (module PARAMETER with type key = int and type value = int))
+module INT_PARAMETER = (val ((parameter () : (module PARAMETER with type key = int and type value = int))))
+
+module type ENVIRONMENT = sig
+  type key
+  type value
+  type t
+
+  val empty : t
+  val get_opt : t -> key -> value option
+  val gets : t -> key -> value list
+  val set : t -> key -> value -> t
+  val del : t -> key -> t
+end
+
+module Make(P:PARAMETER) : ENVIRONMENT with type key = P.key and type value = P.value  = struct
+  type key = P.key
+  type value = P.value
+  type t = (key * value) list
+
+  let empty : t = []
+
+  let gets lst k =
+    let kvs = List.filter (fun (k', _) -> P.key_cmp k k' = 0) lst in
+    List.map snd kvs
+  let get_opt lst k = match gets lst k with
+    | [] -> None
+    | v :: _ -> Some v
+
+  let set lst k v = (k, v) :: lst
+
+  let del lst k =
+    let rec aux acc = function
+      | [] -> List.rev acc
+      | (key, _) :: tl when P.key_cmp key k = 0 -> List.rev acc @ tl
+      | hd :: tl -> aux (hd :: acc) tl in
+    aux [] lst
+end

src/lib_ligo/src/helpers/ligo-helpers.opam

@@ -0,0 +1,23 @@
+name: "ligo-helpers"
+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" { build & >= "1.0.1" }
+  "meta-michelson"
+  "tezos-utils"
+  "tezos-base"
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+  [ "mv" "src/lib_ligo/src/helpers/ligo-helpers.install" "." ]
+]
+url {
+  src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
+}

src/lib_ligo/src/helpers/location.ml

@@ -0,0 +1,24 @@
+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 file_location
+  | Virtual of virtual_location
+
+let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
+  let filename = start_pos.pos_fname in
+  let start_line = start_pos.pos_lnum in
+  let end_line = end_pos.pos_lnum in
+  let start_column = start_pos.pos_cnum - start_pos.pos_bol in
+  let end_column = end_pos.pos_cnum - end_pos.pos_bol in
+  File { filename ; start_line ; start_column ; end_line ; end_column }
+
+let virtual_location s = Virtual s
+let dummy = virtual_location "dummy"

src/lib_ligo/src/helpers/option.ml

@@ -0,0 +1,3 @@
+let unopt ~default = function
+  | None -> default
+  | Some x -> x

src/lib_ligo/src/helpers/trace.ml

@@ -0,0 +1,157 @@
+type error = {
+  message : string ;
+  title : string ;
+}
+
+type 'a result =
+    Ok of 'a
+  | Errors of error list
+
+let ok x = Ok x
+let fail err = Errors [err]
+
+let simple_error str = {
+  message = "" ;
+  title = str ;
+}
+
+let error title message = { title ; message }
+
+let simple_fail str = fail @@ simple_error str
+
+let map f = function
+  | Ok x -> f x
+  | Errors _ as e -> e
+
+let apply f = function
+  | Ok x -> Ok (f x)
+  | Errors _ as e -> e
+
+let (>>?) x f = map f x
+let (>>|?) = apply
+
+module Let_syntax = struct
+  let bind m ~f = m >>? f
+end
+
+let trace err = function
+  | Ok _ as o -> o
+  | Errors errs -> Errors (err :: errs)
+
+let trace_option error = function
+  | None -> fail error
+  | Some s -> ok s
+
+let rec bind_list = function
+  | [] -> ok []
+  | hd :: tl -> (
+      hd >>? fun hd ->
+      bind_list tl >>? fun tl ->
+      ok @@ hd :: tl
+    )
+
+let bind_or (a, b) =
+  match a with
+  | Ok x -> ok x
+  | _ -> 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 x, _ -> ok @@ `Left x
+  | _, Ok x -> ok @@ `Right x
+  | _, Errors b -> Errors b
+
+let bind_and (a, b) =
+  a >>? fun a ->
+  b >>? fun b ->
+  ok (a, b)
+
+module AE = Tezos_utils.Memory_proto_alpha.Alpha_environment
+module TP = Tezos_base__TzPervasives
+
+let of_tz_error (err:Tezos_utils.Error_monad.error) : error =
+  let str = Tezos_utils.Error_monad.(to_string err) in
+  error "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)
+
+let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
+  trace_tzresult 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 sequence f lst =
+  let rec aux acc = function
+    | hd :: tl -> (
+        match f hd with
+        | Ok x -> aux (x :: acc) tl
+        | Errors _ as errs -> errs
+      )
+    | [] -> ok @@ List.rev acc in
+  aux [] lst
+
+let error_pp fmt error =
+  if error.message = ""
+  then Format.fprintf fmt "%s" error.title
+  else Format.fprintf fmt "%s : %s" error.title error.message
+
+let error_pp_short fmt error =
+  Format.fprintf fmt "%s" error.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_true ~msg = function
+    | true -> ok ()
+    | false -> simple_fail msg
+
+  let assert_equal_int ?msg a b =
+    let msg = Option.unopt ~default:"not equal int" msg in
+    assert_true ~msg (a = b)
+
+  let assert_list_size ~msg lst n =
+    assert_true ~msg (List.length lst = n)
+
+  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

src/lib_ligo/src/helpers/wrap.ml

@@ -0,0 +1,21 @@
+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

src/ligo/helpers/dictionary.ml

@@ -0,0 +1,33 @@
+open Trace
+
+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 =
+    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 =
+    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

src/ligo/helpers/dictionary.mli

@@ -0,0 +1,16 @@
+open Trace
+
+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

src/ligo/helpers/dune

@@ -0,0 +1,8 @@
+(library
+  (libraries
+    tezos-base
+    tezos-utils
+  )
+  (name ligo_helpers)
+  (public_name ligo-helpers)
+)

src/ligo/helpers/environment.ml

@@ -0,0 +1,53 @@
+module type PARAMETER = sig
+  type key
+  type value
+  val key_cmp : key -> key -> int
+  val value_cmp : value -> value -> int
+end
+
+let parameter (type key value) ?key_cmp ?value_cmp () : (module PARAMETER with type key = key and type value = value) =
+  (module struct
+    type nonrec key = key
+    type nonrec value = value
+    let key_cmp = Option.unopt ~default:compare key_cmp
+    let value_cmp = Option.unopt ~default:compare value_cmp
+  end)
+
+let int_parameter = (parameter () : (module PARAMETER with type key = int and type value = int))
+module INT_PARAMETER = (val ((parameter () : (module PARAMETER with type key = int and type value = int))))
+
+module type ENVIRONMENT = sig
+  type key
+  type value
+  type t
+
+  val empty : t
+  val get_opt : t -> key -> value option
+  val gets : t -> key -> value list
+  val set : t -> key -> value -> t
+  val del : t -> key -> t
+end
+
+module Make(P:PARAMETER) : ENVIRONMENT with type key = P.key and type value = P.value  = struct
+  type key = P.key
+  type value = P.value
+  type t = (key * value) list
+
+  let empty : t = []
+
+  let gets lst k =
+    let kvs = List.filter (fun (k', _) -> P.key_cmp k k' = 0) lst in
+    List.map snd kvs
+  let get_opt lst k = match gets lst k with
+    | [] -> None
+    | v :: _ -> Some v
+
+  let set lst k v = (k, v) :: lst
+
+  let del lst k =
+    let rec aux acc = function
+      | [] -> List.rev acc
+      | (key, _) :: tl when P.key_cmp key k = 0 -> List.rev acc @ tl
+      | hd :: tl -> aux (hd :: acc) tl in
+    aux [] lst
+end

src/ligo/helpers/ligo-helpers.opam

@@ -0,0 +1,22 @@
+name: "ligo-helpers"
+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" { build & >= "1.0.1" }
+  "meta-michelson"
+  "tezos-utils"
+  "tezos-base"
+]
+build: [
+  [ "dune" "build" "-p" name "-j" jobs ]
+]
+url {
+  src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz"
+}

src/ligo/helpers/location.ml

@@ -0,0 +1,24 @@
+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 file_location
+  | Virtual of virtual_location
+
+let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t =
+  let filename = start_pos.pos_fname in
+  let start_line = start_pos.pos_lnum in
+  let end_line = end_pos.pos_lnum in
+  let start_column = start_pos.pos_cnum - start_pos.pos_bol in
+  let end_column = end_pos.pos_cnum - end_pos.pos_bol in
+  File { filename ; start_line ; start_column ; end_line ; end_column }
+
+let virtual_location s = Virtual s
+let dummy = virtual_location "dummy"

src/ligo/helpers/option.ml

@@ -0,0 +1,3 @@
+let unopt ~default = function
+  | None -> default
+  | Some x -> x

src/ligo/helpers/trace.ml

@@ -0,0 +1,157 @@
+type error = {
+  message : string ;
+  title : string ;
+}
+
+type 'a result =
+    Ok of 'a
+  | Errors of error list
+
+let ok x = Ok x
+let fail err = Errors [err]
+
+let simple_error str = {
+  message = "" ;
+  title = str ;
+}
+
+let error title message = { title ; message }
+
+let simple_fail str = fail @@ simple_error str
+
+let map f = function
+  | Ok x -> f x
+  | Errors _ as e -> e
+
+let apply f = function
+  | Ok x -> Ok (f x)
+  | Errors _ as e -> e
+
+let (>>?) x f = map f x
+let (>>|?) = apply
+
+module Let_syntax = struct
+  let bind m ~f = m >>? f
+end
+
+let trace err = function
+  | Ok _ as o -> o
+  | Errors errs -> Errors (err :: errs)
+
+let trace_option error = function
+  | None -> fail error
+  | Some s -> ok s
+
+let rec bind_list = function
+  | [] -> ok []
+  | hd :: tl -> (
+      hd >>? fun hd ->
+      bind_list tl >>? fun tl ->
+      ok @@ hd :: tl
+    )
+
+let bind_or (a, b) =
+  match a with
+  | Ok x -> ok x
+  | _ -> 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 x, _ -> ok @@ `Left x
+  | _, Ok x -> ok @@ `Right x
+  | _, Errors b -> Errors b
+
+let bind_and (a, b) =
+  a >>? fun a ->
+  b >>? fun b ->
+  ok (a, b)
+
+module AE = Tezos_utils.Memory_proto_alpha.Alpha_environment
+module TP = Tezos_base__TzPervasives
+
+let of_tz_error (err:Tezos_utils.Error_monad.error) : error =
+  let str = Tezos_utils.Error_monad.(to_string err) in
+  error "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)
+
+let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result =
+  trace_tzresult 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 sequence f lst =
+  let rec aux acc = function
+    | hd :: tl -> (
+        match f hd with
+        | Ok x -> aux (x :: acc) tl
+        | Errors _ as errs -> errs
+      )
+    | [] -> ok @@ List.rev acc in
+  aux [] lst
+
+let error_pp fmt error =
+  if error.message = ""
+  then Format.fprintf fmt "%s" error.title
+  else Format.fprintf fmt "%s : %s" error.title error.message
+
+let error_pp_short fmt error =
+  Format.fprintf fmt "%s" error.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_true ~msg = function
+    | true -> ok ()
+    | false -> simple_fail msg
+
+  let assert_equal_int ?msg a b =
+    let msg = Option.unopt ~default:"not equal int" msg in
+    assert_true ~msg (a = b)
+
+  let assert_list_size ~msg lst n =
+    assert_true ~msg (List.length lst = n)
+
+  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

src/ligo/helpers/wrap.ml

@@ -0,0 +1,21 @@
+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