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

I rewrote some comments so [dune build @doc] can extract HTML from

Browse Source 
module interfaces.

This is meant as an exercise and an example to all team members.

I fixed a minor shadowing issue in [x_list.ml].
This commit is contained in:
Christian Rinderknecht 2019-12-06 11:49:19 +01:00
parent c3e904ca00
commit c4182fa6fd
5 changed files with 453 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

97
vendors/ligo-utils/simple-utils/pos.mli vendored
View File

@ -1,4 +1,4 @@
(* Positions in a file (** Positions in a file
A position in a file denotes a single unit belonging to it, for 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 example, in an ASCII text file, it is a particular character within
@ -7,22 +7,57 @@
Units can be either bytes (as ASCII characters) or, more Units can be either bytes (as ASCII characters) or, more
generally, unicode points. generally, unicode points.
*)
The type for positions is the object type [t]. (** {1 Definition} *)
(** The type for positions is the object type [t].
We use here lexing positions to denote byte-oriented positions We use here lexing positions to denote byte-oriented positions
(field [byte]), and we manage code points by means of the fields (field [byte]), and we manage code points by means of the fields
[point_num] and [point_bol]. These two fields have a meaning [point_num] and [point_bol]. These two fields have a meaning
similar to the fields [pos_cnum] and [pos_bol], respectively, from similar to the fields [pos_cnum] and [pos_bol], respectively, from
the standard module [Lexing]. That is to say, [point_num] holds the the standard module {! Lexing}. That is to say, [point_num] holds
number of code points since the beginning of the file, and the number of code points since the beginning of the file, and
[point_bol] the number of code points since the beginning of the [point_bol] the number of code points since the beginning of the
current line. current line.
The name of the file is given by the field [file], and the line {ul
number by the field [line].
*)
{li The name of the file is given by the field [file], and the
line number by the field [line].}
{li The call [pos#new_line s], where the string [s] is either
["\n"] or ["\c\r"], updates the position [pos] with a new
line.}
{li The call [pos#add_nl] assumes that the newline character is
one byte.}
{li The call [pos#shift_bytes n] evaluates in a position that is
the translation of position [pos] of [n] bytes forward in the
file.}
{li 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.}
{li 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.}
{li The calls to the method [column] are similar to those to
[offset], except that they give the curren column number.}
{li 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.}
{li The call [pos#byte_offset] is the offset of the position
[pos] since the begininng of the file, counted in bytes.}}
*)
type t = < type t = <
(* Payload *) (* Payload *)
@ -39,43 +74,16 @@ type t = <
set_offset : int -> t; set_offset : int -> t;
set : file:string -> line:int -> 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; new_line : string -> t;
add_nl : 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_bytes : int -> t;
shift_one_uchar : int -> t; shift_one_uchar : int -> t;
(* Getters *) (* Getters *)
(* The call [pos#offset `Byte] provides the horizontal offset of the offset : [`Byte | `Point] -> int;
position [pos] in bytes. (An offset is the number of units, like column : [`Byte | `Point] -> int;
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; line_offset : [`Byte | `Point] -> int;
byte_offset : int; byte_offset : int;
@ -90,19 +98,26 @@ type t = <
anonymous : ?offsets:bool -> [`Byte | `Point] -> string anonymous : ?offsets:bool -> [`Byte | `Point] -> string
> >
(** A shorthand after an [open Pos].
*)
type pos = t type pos = t
(* Constructors *) (** {1 Constructors} *)
val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t
val from_byte : Lexing.position -> t val from_byte : Lexing.position -> t
(* Special positions *) (** {1 Special positions} *)
val ghost : t (* Same as [Lexing.dummy_pos] *) (** The value [ghost] is the same as {! Lexing.dummy_pos}.
val min : t (* Lexing convention: line 1, offsets to 0 and file to "". *) *)
val ghost : t
(* Comparisons *) (** Lexing convention: line [1], offsets to [0] and file to [""].
*)
val min : t
(** {1 Comparisons} *)
val equal : t -> t -> bool val equal : t -> t -> bool
val lt : t -> t -> bool val lt : t -> t -> bool

8
vendors/ligo-utils/simple-utils/region.ml vendored
View File

@ -1,7 +1,11 @@
(* Regions of a file *) (* Regions of a file *)
(* A shorthand *)
let sprintf = Printf.sprintf let sprintf = Printf.sprintf
(* The object type for regions *)
type t = < type t = <
start : Pos.t; start : Pos.t;
stop : Pos.t; stop : Pos.t;
@ -28,8 +32,12 @@ type t = <
compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string
> >
(* A synonym *)
type region = t type region = t
(* A convenience *)
type 'a reg = {region: t; value: 'a} type 'a reg = {region: t; value: 'a}
(* Injections *) (* Injections *)

177
vendors/ligo-utils/simple-utils/region.mli vendored
View File

@ -1,44 +1,73 @@
(* Regions of a file (** Regions of a file
A _region_ is a contiguous series of bytes, for example, in a text A {e region} is a contiguous series of bytes, for example, in a
file. It is here denoted by the object type [t]. text file. It is here denoted by the object type [t].
*)
The start (included) of the region is given by the field [start], (** {1 Definition} *)
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, (** The start (included) of the region is given by the field [start],
column one), and [start] is always lower than or equal to [stop], which is a {e position}, and the end (excluded) is the position
and they must refer to the same file. 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], which a fast and easy check. 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.
{ul
{li The call [region#shift_bytes n] evaluates in a region that
is the translation of region [region] of [n] bytes forward
in the file.}
{li The call [region#shift_one_uchar n] is similar to
[region#shift_bytes n], except that it assumes that [n] is
the number of bytes making up one unicode point.}
{li The call [region#set_file f] sets the file name to be [f].}
{li The method [file] returns the file name.}
{li The method [pos] returns the values of the fields [start]
and [stop].}
{li The method [byte_pos] returns the start and end positions of
the region at hand {e interpreting them as lexing
positions}, that is, the unit is the byte.}
{li The call [region#to_string ~file ~offsets mode] evaluates in
a string denoting the region [region], in the manner of the
OCaml compilers.}
{li The name of the file is present if, and only if, [file =
true] or [file] is missing.}
{li The positions in the file are expressed as horizontal
offsets if [offsets = true] or [offsets] is missing (the
default), otherwise as columns.}
{li 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.}
{li The method [compact] has the same signature as and calling
convention as [to_string], except that the resulting string
is more compact.}}
*)
type t = < type t = <
start : Pos.t; start : Pos.t;
stop : Pos.t; stop : Pos.t;
(* Setters *) (* 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_bytes : int -> t;
shift_one_uchar : int -> t; shift_one_uchar : int -> t;
set_file : string -> t; set_file : string -> t;
(* Getters *) (* 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; file : string;
pos : Pos.t * Pos.t; pos : Pos.t * Pos.t;
byte_pos : Lexing.position * Lexing.position; byte_pos : Lexing.position * Lexing.position;
@ -47,84 +76,70 @@ type t = <
is_ghost : bool; is_ghost : bool;
(* Conversions to [string] *) (* Conversions to type [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; to_string : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string
> >
(** The type [region] is a synonym of [t] to use after [open Region].
*)
type region = t type region = t
(** The type ['a reg] enables the concept of something of type ['a] to
be related to a region in a source file.
*)
type 'a reg = {region: t; value: 'a} type 'a reg = {region: t; value: 'a}
(* Constructors *) (* {1 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 exception Invalid
(** 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.
@raise [Invalid]
*)
val make : start:Pos.t -> stop:Pos.t -> t val make : start:Pos.t -> stop:Pos.t -> t
(* Special regions *) (** {1 Special regions} *)
(* To deal with ghost expressions, that is, pieces of abstract syntax (** To deal with ghost expressions, that is, pieces of abstract syntax
that have not been built from excerpts of concrete syntax, we need that have not been built from excerpts of concrete syntax, we need
_ghost regions_. The module [Pos] provides a [ghost] position, and {e ghost regions}. The module {! Pos} provides a [ghost] position,
we also provide a [ghost] region and, in type [t], the method and we also provide a [ghost] region and, in type [t], the method
[is_ghost] to check it. *) [is_ghost] to check it. It is implemented as two [Pos.ghost]
positions. *)
val ghost : t (* Two [Pos.ghost] positions *) val ghost : t
(* This wraps a value with a ghost region. *)
(** The call to [wrap_ghost] wraps a value within a ghost region.
*)
val wrap_ghost : 'a -> 'a reg val wrap_ghost : 'a -> 'a reg
(** Occasionnally, we may need a minimum region. It is here made of
two minimal positions.
*)
val min : t
(* Occasionnally, we may need a minimum region. It is here made of two (** {1 Comparisons} *)
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. *)
(** 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 val equal : t -> t -> bool
(* The call [lt r1 r2] ("lower than") has the value [true] if, and (** 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 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 ghost and the start position of [r1] is lower than that of
[r2]. (See [Pos.lt].) *) [r2]. (See {! Pos.lt}.) *)
val lt : t -> t -> bool val lt : t -> t -> bool
(* Given two regions [r1] and [r2], we may want the region [cover r1 (** 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) r2] that covers [r1] and [r2]. We have the property [equal (cover
(cover r2 r1)]. (In a sense, it is the maximum region, but we avoid r1 r2) (cover r2 r1)]. (In a sense, it is the maximum region, but
that name because of the [min] function above.) If [r1] is a ghost, we avoid that name because of the [min] function above.) If [r1]
the cover is [r2], and if [r2] is a ghost, the cover is [r1]. *) is a ghost, the cover is [r2], and if [r2] is a ghost, the cover
is [r1].
*)
val cover : t -> t -> t val cover : t -> t -> t

584
vendors/ligo-utils/simple-utils/trace.ml vendored
View File

@ -1,355 +1,360 @@
(** Trace tutorial (** Trace tutorial
The module below guides the reader through the writing of a This module guides the reader through the writing of a simplified
simplified version of the trace monad (`result`), and the version of the trace monad [result], and the definition of a few
definition of a few operations that make it easier to work with operations that make it easier to work with [result].
`result`.
*) *)
module Trace_tutorial = struct module Trace_tutorial = struct
(** The trace monad is fairly similar to the option type: *) (** The trace monad is fairly similar to the predefined option
type. *)
type 'a option = type annotation = string
Some of 'a (* Ok also stores a list of annotations *) type error = string
| None;; (* Errors also stores a list of messages *)
type annotation = string;; (** The type ['a result] is used by the trace monad to both model an
type error = string;; expected value of type ['a] or the failure to obtain it, instead
type 'a result = of working directly with ['a] values and handling separately
errors, for example by means of exceptions. (See the type [('a,'b)
result] in the module [Pervasives] of the OCaml system for a
comparable approach to error handling.)
The type ['a result] carries either a value of type ['a], with a
list of annotations (information about past successful
computations), or it is a list of errors accumulated so far.
The former case is denoted by the data constructor [Ok], and the
second by [Errors].
*)
type 'a result =
Ok of 'a * annotation list Ok of 'a * annotation list
| Errors of error list;; | Errors of error list
(** When applying a partial function on a result, it can return a valid result (** The function [divide_trace] shows the basic use of the trace
(Some v), or indicate failure (None). *) monad.
*)
let divide_trace a b =
if b = 0
then Errors [Printf.sprintf "division by zero: %d/%d" a b]
else Ok (a/b, [])
let divide a b = (** The function [divide_three] shows that when composing two
if b = 0 functions, if the first call fails, the error is passed along
then None and the second call is not evaluated. (A pattern called
else Some (a/b);; "error-passing style").
*)
let divide_three a b c =
match divide_trace a b with
Ok (a_div_b , _) -> divide_trace a_div_b c
| errors -> errors
(** With the trace monad, the Errors case also indicates some information about (** The function [divide_three_annot] shows that when composing two
the failure, to ease debugging. *) functions, if both calls are successful, the lists of
annotations are joined.
*)
let divide_three_annot a b c =
match divide_trace a b with
Ok (a_div_b, annot1) -> (
match divide_trace a_div_b c with
Ok (a_div_b_div_c, annot2) ->
Ok (a_div_b_div_c, annot2 @ annot1)
| errors -> errors)
| errors -> errors
let divide_trace a b = (** The systematic matching of the result of each call in a function
if b = 0 composition is bulky, so we define a [bind] function which takes
then (Errors [Printf.sprintf "division by zero: %d / %d" a b]) a function [f: 'a -> 'b result] and applies it to a current ['a
else Ok ((a/b) , []);; result] (not ['a]).
{ul
{li If the current result is an error, then [bind]
returns that same error without calling [f];}
(** when composing two functions, the error case is propagated. *) {li otherwise [bind] unwraps the [Ok] of the current result
and calls [f] on it:
{ul
{li That call itself may return an error;}
{li if not, [bind] combines the annotations and returns the last
result.}}}}
*)
let bind (f: 'a -> 'b result) : 'a result -> 'b result =
function
Ok (x, annot) -> (
match f x with
Ok (x', annot') -> Ok (x', annot' @ annot)
| errors -> ignore annot; errors)
| Errors _ as e -> e
let divide_three a b c = (** The function [divide_three_bind] is equivalent to the verbose
let maybe_a_div_b = divide_trace a b in [divide_three] above, but makes use of [bind].
match maybe_a_div_b with *)
Ok (a_div_b , _) -> divide_trace a_div_b c let divide_three_bind a b c =
| (Errors _) as e -> e;; let maybe_a_div_b = divide_trace a b in
let continuation a_div_b = divide_trace a_div_b c
in bind continuation maybe_a_div_b
(** If both calls are successful, the lists of annotations are concatenated. *) (** The operator [(>>?)] is a redefinition of [bind] that makes the
program shorter, at the cost of a slightly
awkward reading because the two parameters are swapped.
*)
let (>>?) x f = bind f x
let divide_three_annots a b c = (** The function [divide_three_bind_symbol] is equivalent to
let maybe_a_div_b = divide_trace a b in [divide_three_bind], but makes use of the operator [(>>?)].
match maybe_a_div_b with *)
Ok (a_div_b , annots1) -> let divide_three_bind_symbol a b c =
let maybe_a_div_b_div_c = divide_trace a_div_b c in let maybe_a_div_b = divide_trace a b in
begin let continuation a_div_b = divide_trace a_div_b c in
match maybe_a_div_b_div_c with maybe_a_div_b >>? continuation
Ok (a_div_b_div_c , annots2)
-> Ok (a_div_b_div_c , annots2 @ annots1)
| (Errors _) as e2 -> e2
end
| (Errors _) as e1 -> e1;;
(** This incurs quite a lot of noise, so we define a `bind` operator which (** The function [divide_three_bind_symbol'] is equivalent to
takes a function ('x -> ('y result)) and applies it to an existing [divide_three_bind_symbol], where the two temporary [let]
('x result). definitions are inlined for a more compact reading.
*)
let divide_three_bind_symbol' a b c =
divide_trace a b >>? (fun a_div_b -> divide_trace a_div_b c)
* If the existing result is Errors, `bind` returns that error without (** This is now fairly legible, but chaining many such functions is
calling the function not the usual way of writing code. We use the PPX extension to
* Otherwise `bind` unwraps the Ok and calls the function the OCaml compiler [ppx_let] to add some syntactic sugar.
* That function may itself return an error The extension framework PPX is enabled by adding the following
* Otherwise `bind` combines the annotations and returns the second lines inside the section [(library ...)] or [(executable ...)]
result. *) of the [dune] file for the project that uses [ppx_let], like so:
[(preprocess
(pps simple-utils.ppx_let_generalized))]
The extension [ppx_let] requires the module [Let_syntax] to be
defined.
*)
module Let_syntax = struct
let bind m ~f = m >>? f
module Open_on_rhs_bind = struct end
end
let bind f = function (** The function [divide_three_bind_ppx_let] is equivalent to the
| Ok (x, annotations) -> function [divide_three_bind_symbol']. The only difference is
(match f x with that the module [Open_on_rhs_bind] is implicitly opened around
Ok (x', annotations') -> Ok (x', annotations' @ annotations) the expression on the righ-hand side of the [=] sign, namely
| Errors _ as e' -> ignore annotations; e') [divide_trace a b].
| Errors _ as e -> e;; *)
let divide_three_bind_ppx_let a b c =
let%bind a_div_b = divide_trace a b
in divide_trace a_div_b c
(** The following function divide_three_bind is equivalent to the verbose (** The function [divide_many_bind_ppx_let] shows how well this
divide_three. *) notation composes.
*)
let divide_many_bind_ppx_let a b c d e f =
let x = a in
let%bind x = divide_trace x b in
let%bind x = divide_trace x c in
let%bind x = divide_trace x d in
let%bind x = divide_trace x e in
let%bind x = divide_trace x f
in Ok (x, [])
let divide_three_bind a b c = (** The function [ok] is a shorthand for an [Ok] without
let maybe_a_div_b = divide_trace a b in annotations.
let continuation a_div_b = divide_trace a_div_b c in *)
bind continuation maybe_a_div_b;; let ok x = Ok (x, [])
(** This made the code shorter, but the reading order is a bit awkward. (** The function [map] lifts a regular ['a -> 'b] function on values to
We define an operator symbol for `bind`: *) a function on results, of type ['a result -> 'b result].
*)
let map f = function
Ok (x, annotations) -> Ok (f x, annotations)
| e -> e
let (>>?) x f = bind f x;; (** The function [bind_list] turns a list of results of type [('a
result) list] into a result of list, of type [('a list) result],
as follows.
{ul
{li If the list only contains [Ok] values, it strips the [Ok]
of each element and returns that list wrapped with [Ok].}
{li Otherwise, one or more of the elements of the input list
is [Errors], then [bind_list] returns the first error in the
list.}}
*)
let rec bind_list = function
[] -> ok []
| hd::tl ->
hd >>? fun hd ->
bind_list tl >>? fun tl ->
ok @@ hd::tl
(** A major feature of [Trace] is that it enables having a stack of
errors (that should act as a simplified stack frame), rather
than a unique error. It is done by using the function
[trace]. For instance, let's say that you have a function that
can trigger two errors, and you want to pass their data along
with an other error, what you would usually do is:
[let foobarer ... = ... in
let value =
try get key map with
Bad_key _ -> raise (Error ("bad key", key, map))
| Missing_value _ -> raise (Error ("missing index", key, map))
in ...]
With [Trace], you would instead:
[let foobarer ... = ... in
let%bind value =
trace (simple_error "error getting key") @@
get key map
in ...]
And this will pass along the error triggered by [get key map].
*)
let trace err = function
Errors e -> Errors (err::e)
| ok -> ok
let divide_three_bind_symbol a b c = (** The real trace monad is very similar to the one that we have
let maybe_a_div_b = divide_trace a b in defined above. The main difference is that the errors and
let continuation a_div_b = divide_trace a_div_b c in annotations are structured data (instead of plain strings) and
maybe_a_div_b >>? continuation;; are generated lazily.
*)
(** and we inline the two temporary let definitions: *) let the_end = "End of the tutorial."
let divide_three_bind_symbol' a b c =
divide_trace a b >>? (fun a_div_b -> divide_trace a_div_b c);;
(** This is now fairly legible, but chaining many such functions is
not the usual way of writing code. We use ppx_let to add some
syntactic sugar.
The ppx is enabled by adding the following lines inside the
section (library …) or (executable …) of the dune file for
the project that uses ppx_let.
(preprocess
(pps simple-utils.ppx_let_generalized))
*)
module Let_syntax = struct
let bind m ~f = m >>? f
module Open_on_rhs_bind = struct end
end;;
(** divide_three_bind_ppx_let is equivalent to divide_three_bind_symbol'.
Strictly speaking, the only difference is that the module
Open_on_rhs_bind is opened around the expression on the righ-hand side
of the `=` sign, namely `divide_trace a b` *)
let divide_three_bind_ppx_let a b c =
let%bind a_div_b = divide_trace a b in
divide_trace a_div_b c;;
(** This notation scales fairly well: *)
let divide_many_bind_ppx_let a b c d e f =
let x = a in
let%bind x = divide_trace x b in
let%bind x = divide_trace x c in
let%bind x = divide_trace x d in
let%bind x = divide_trace x e in
let%bind x = divide_trace x f in
Ok (x , []);;
(** We define a couple of shorthands for common use cases.
`ok` lifts a ('foo) value to a ('foo result): *)
let ok x = Ok (x, []);;
(** `map` lifts a regular ('foo -> 'bar) function on values
to a function on results, with type ('foo result -> 'bar result): *)
let map f = function
| Ok (x, annotations) -> Ok (f x, annotations)
| Errors _ as e -> e;;
(** `bind_list` turns a (('foo result) list) into a (('foo list) result).
If the list only contains Ok values, it strips the Ok returns that list
wrapped with Ok.
Otherwise, when one or more of the elements of the original list is
Errors, `bind_list` returns the first error in the list. *)
let rec bind_list = function
| [] -> ok []
| hd :: tl -> (
hd >>? fun hd ->
bind_list tl >>? fun tl ->
ok @@ hd :: tl
);;
(**
A major feature of Trace is that it enables having a stack of errors (that
should act as a simplified stack frame), rather than a unique error.
It is done by using the function `trace`.
For instance, let's say that you have a function that can trigger two errors,
and you want to pass their data along with an other error, what you would
usually do is:
```
let foobarer ... =
... in
let value =
try ( get key map )
with
| Bad_key _ -> raise (Foobar_error ("bad key" , key , map))
| Missing_value _ -> raise (Foobar_error ("missing index" , key , map))
in ...
```
With Trace, you would instead:
```
let foobarer ... =
... in
let%bind value =
trace (simple_error "error getting key") @@
get key map
in ...
```
And this will pass along the error triggered by "get key map".
*)
let trace err = function
| Ok _ as o -> o
| Errors errs -> Errors (err :: errs);;
(** The real trace monad is very similar to the one that we have
defined above. The main difference is that the errors and
annotations are structured data (instead of plain strings) and are
lazily-generated. *)
let the_end = "End of the tutorial.";;
end (* end Trace_tutorial. *) end (* end Trace_tutorial. *)
module J = Yojson.Basic module J = Yojson.Basic
module JSON_string_utils = struct module JSON_string_utils = struct
let member = fun n x -> let member n x =
match x with match x with
| `Null -> `Null `Null -> `Null
| x -> J.Util.member n x | x -> J.Util.member n x
let string = J.Util.to_string_option let string = J.Util.to_string_option
let to_list_option = fun x -> let to_list_option = fun x ->
try ( Some (J.Util.to_list x)) try Some (J.Util.to_list x) with _ -> None
with _ -> None
let to_assoc_option = fun x -> let to_assoc_option = fun x ->
try ( Some (J.Util.to_assoc x)) try Some (J.Util.to_assoc x) with _ -> None
with _ -> None
let list = to_list_option let list = to_list_option
let assoc = to_assoc_option let assoc = to_assoc_option
let int = J.Util.to_int_option let int = J.Util.to_int_option
let patch j k v = let patch j k v =
match assoc j with match assoc j with
| None -> j None -> j
| Some assoc -> `Assoc ( | Some assoc -> `Assoc (
List.map (fun (k' , v') -> (k' , if k = k' then v else v')) assoc List.map (fun (k', v') -> (k', if k = k' then v else v')) assoc
) )
let swap f l r = f r l let swap f l r = f r l
let unit x = Some x let unit x = Some x
let bind f = function None -> None | Some x -> Some (f x) let bind f = function None -> None | Some x -> Some (f x)
let bind2 f = fun l r -> match l, r with
let bind2 f l r =
match l, r with
None, None -> None None, None -> None
| None, Some _ -> None | None, Some _ -> None
| Some _, None -> None | Some _, None -> None
| Some l, Some r -> Some (f l r) | Some l, Some r -> Some (f l r)
let default d = function let default d = function
Some x -> x Some x -> x
| None -> d | None -> d
let string_of_int = bind string_of_int let string_of_int = bind string_of_int
let (||) l r = l |> default r let (||) l r = l |> default r
let (|^) = bind2 (^) let (|^) = bind2 (^)
end end
type 'a thunk = unit -> 'a type 'a thunk = unit -> 'a
(** (** Errors are encoded in JSON. This is because different libraries
Errors are encoded in JSON. This is because different libraries will will implement their own helpers, and we do not want to hardcode
implement their own helpers, and we don't want to hardcode in their type how in their type how they are supposed to interact.
they are supposed to interact. *)
*)
type error = J.t type error = J.t
(** (** Thunks are used because computing some errors can be costly, and
Thunks are used because computing some errors can be costly, and we don't we do not want to spend most of our time building errors. Instead,
to spend most of our time building errors. Instead, their computation is their computation is deferred.
deferred. *)
*)
type error_thunk = error thunk type error_thunk = error thunk
(** (** Annotations should be used in debug mode to aggregate information
Annotations should be used in debug mode to aggregate information about some about some value history. Where it was produced, when it was
value history. Where it was produced, when it was modified, etc. modified, etc. It is currently not being used. *)
It's currently not being used.
*)
type annotation = J.t type annotation = J.t
(** (** Even in debug mode, building annotations can be quite
Even in debug mode, building annotations can be quite resource-intensive. resource-intensive. Instead, a thunk is passed, that is computed
Instead, a thunk is passed, that is computed only when debug information is only when debug information is queried (typically before a print).
queried (typically before a print). *)
*)
type annotation_thunk = annotation thunk type annotation_thunk = annotation thunk
(** (** Types of traced elements. It might be good to rename it [trace] at
Types of traced elements. It might be good to rename it `trace` at some some point.
point. *)
*)
type 'a result = type 'a result =
| Ok of 'a * annotation_thunk list Ok of 'a * annotation_thunk list
| Error of error_thunk | Error of error_thunk
(** (** {1 Constructors} *)
Constructors
*)
let ok x = Ok (x, []) let ok x = Ok (x, [])
let fail err = Error err let fail err = Error err
(** (** {1 Monadic operators} *)
Monadic operators
*)
let bind f = function let bind f = function
| Ok (x, annotations) -> Ok (x, ann) -> (
(match f x with match f x with
Ok (x', annotations') -> Ok (x', annotations' @ annotations) Ok (x', ann') -> Ok (x', ann' @ ann)
| Error _ as e' -> ignore annotations; e') | Error _ as e' -> ignore ann; e')
| Error _ as e -> e | Error _ as e -> e
let map f = function let map f = function
| Ok (x, annotations) -> Ok (f x, annotations) Ok (x, annotations) -> Ok (f x, annotations)
| Error _ as e -> e | Error _ as e -> e
(** (** The lexical convention usually adopted for the bind function is
Usual bind-syntax is `>>=`, but this is taken from the Tezos code base. Where [>>=], but ours comes from the Tezos code base, where the [result]
the `result` bind is `>>?`, Lwt's (threading library) is `>>=`, and the bind is [>>?], and [Lwt]'s (threading library) is [>>=], and the
combination of both is `>>=?`. combination of both is [>>=?].
*) *)
let (>>?) x f = bind f x let (>>?) x f = bind f x
let (>>|?) x f = map f x let (>>|?) x f = map f x
(** (**
Used by PPX_let, an OCaml preprocessor. Used by PPX_let, an OCaml preprocessor.
What it does is that, when you only care about the case where a result isn't What it does is that, when you only care about the case where a result isn't
an error, instead of writing: an error, instead of writing:
``` [
(* Stuff that might return an error *) >>? fun ok_value -> (* Stuff that might return an error *) >>? fun ok_value ->
(* Stuff being done on the result *) (* Stuff being done on the result *)
``` ]
You can write: You can write:
``` [
let%bind ok_value = (* Stuff that might return an error *) in let%bind ok_value = (* Stuff that might return an error *) in
(* Stuff being done on the result *) (* Stuff being done on the result *)
``` ]
This is much more typical of OCaml. makes the code more readable, easy to This is much more typical of OCaml. This makes the code more
write and refactor. It is used pervasively in LIGO. readable, easy to write and refactor. It is used pervasively in
*) LIGO.
*)
module Let_syntax = struct module Let_syntax = struct
let bind m ~f = m >>? f let bind m ~f = m >>? f
module Open_on_rhs_bind = struct end module Open_on_rhs_bind = struct end
end end
(** (** Build a thunk from a constant.
Build a thunk from a constant. *)
*)
let thunk x () = x let thunk x () = x
(** (** Build a standard error, with a title, a message, an error code and
Build a standard error, with a title, a message, an error code and some data. some data.
*) *)
let mk_error let mk_error
?(error_code : int thunk option) ?(message : string thunk option) ?(error_code : int thunk option) ?(message : string thunk option)
?(data : (string * string thunk) list option) ?(data : (string * string thunk) list option)
@ -407,48 +412,42 @@ let prepend_info = fun info err ->
patch err "infos" (`List infos) patch err "infos" (`List infos)
(** (** Helpers that ideally should not be used in production.
Helpers that ideally shouldn't be used in production.
*) *)
let simple_error str () = mk_error ~title:(thunk str) () let simple_error str () = mk_error ~title:(thunk str) ()
let simple_info str () = mk_info ~title:(thunk str) () let simple_info str () = mk_info ~title:(thunk str) ()
let simple_fail str = fail @@ simple_error str let simple_fail str = fail @@ simple_error str
let internal_assertion_failure str = simple_error ("assertion failed: " ^ str) let internal_assertion_failure str = simple_error ("assertion failed: " ^ str)
(** (** To be used when you only want to signal an error. It can be useful
To be used when you only want to signal an error. It can be useful when when followed by [trace_strong].
followed by `trace_strong`. *)
*)
let dummy_fail = simple_fail "dummy" let dummy_fail = simple_fail "dummy"
let trace info = function let trace info = function
| Ok _ as o -> o Ok _ as o -> o
| Error err -> Error (fun () -> prepend_info (info ()) (err ())) | Error err -> Error (fun () -> prepend_info (info ()) (err ()))
(** (** Erase the current error stack, and replace it by the given
Erase the current error stack, and replace it by the given error. It's useful error. It's useful when using [Assert] and you want to discard its
when using `Assert` and you want to discard its auto-generated message. autogenerated message.
*) *)
let trace_strong err = function let trace_strong err = function
| Ok _ as o -> o Ok _ as o -> o
| Error _ -> Error err | Error _ -> Error err
(** (**
Sometimes, when you have a list of potentially erroneous elements, you need Sometimes, when you have a list of potentially erroneous elements, you need
to retrieve all the errors, instead of just the first one. In that case, do: to retrieve all the errors, instead of just the first one. In that case, do:
``` [let type_list lst =
let type_list lst =
let%bind lst' = let%bind lst' =
trace_list (simple_error "Error while typing a list") @@ trace_list (simple_error "Error while typing a list") @@
List.map type_element lst in List.map type_element lst in
... ...]
```
Where before you would have written: Where before you would have written:
``` [let type_list lst =
let type_list lst =
let%bind lst' = bind_map_list type_element lst in let%bind lst' = bind_map_list type_element lst in
... ...]
```
*) *)
let trace_list err lst = let trace_list err lst =
let oks = let oks =
@ -520,18 +519,16 @@ let trace_option error = function
| None -> fail error | None -> fail error
| Some s -> ok s | Some s -> ok s
(** (** Utilities to interact with other data-structure. [bind_t] takes
Utilities to interact with other data-structure. an ['a result t] and makes a ['a t result] out of it. It "lifts" the
`bind_t` takes an `'a result t` and makes a `'a t result` out of it. It error out of the type. The most common context is when mapping a
"lifts" the error out of the type. given type. For instance, if you use a function that can fail in
The most common context is when mapping a given type. For instance, if you [List.map], you need to manage a whole list of results. Instead,
use a function that can fail in `List.map`, you need to manage a whole list you do [let%bind lst' = bind_list @@ List.map f lst], which will
of results. Instead, you do `let%bind lst' = bind_list @@ List.map f lst`, yield an ['a list]. [bind_map_t] is roughly syntactic sugar for
which will yield an `'a list`. [bind_t @@ T.map]. So that you can rewrite the previous example as
`bind_map_t` is roughly syntactic sugar for `bind_t @@ T.map`. So that you [let%bind lst' = bind_map_list f lst]. Same thing with folds.
can rewrite the previous example as `let%bind lst' = bind_map_list f lst`. *)
Same thing with folds.
*)
let bind_map_option f = function let bind_map_option f = function
| None -> ok None | None -> ok None
@ -560,10 +557,8 @@ let bind_smap (s:_ X_map.String.t) =
let bind_fold_smap f init (smap : _ X_map.String.t) = let bind_fold_smap f init (smap : _ X_map.String.t) =
let aux k v prev = let aux k v prev =
prev >>? fun prev' -> prev >>? fun prev' -> f prev' k v
f prev' k v in X_map.String.fold aux smap init
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_smap f smap = bind_smap (X_map.String.map f smap)
@ -573,6 +568,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) =
ok @@ (l1' @ l2') ok @@ (l1' @ l2')
let bind_map_list f lst = bind_list (List.map f lst) let bind_map_list f lst = bind_list (List.map f lst)
let rec bind_map_list_seq f lst = match lst with let rec bind_map_list_seq f lst = match lst with
| [] -> ok [] | [] -> ok []
| hd :: tl -> ( | hd :: tl -> (
@ -580,9 +576,10 @@ let rec bind_map_list_seq f lst = match lst with
let%bind tl' = bind_map_list_seq f tl in let%bind tl' = bind_map_list_seq f tl in
ok (hd' :: tl') ok (hd' :: tl')
) )
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_map_ne_list : _ -> 'a X_list.Ne.t -> 'b X_list.Ne.t result =
let bind_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst -> fun f lst -> bind_ne_list (X_list.Ne.map f lst)
bind_map_list f lst >>? fun _ -> ok () 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) = let bind_location (x:_ Location.wrap) =
x.wrap_content >>? fun wrap_content -> x.wrap_content >>? fun wrap_content ->
@ -847,4 +844,3 @@ let errors_pp_short =
Format.pp_print_list Format.pp_print_list
~pp_sep:Format.pp_print_newline ~pp_sep:Format.pp_print_newline
error_pp_short error_pp_short

2
vendors/ligo-utils/simple-utils/x_list.ml vendored
View File

@ -178,7 +178,7 @@ module Ne = struct
type 'a t = 'a * 'a list type 'a t = 'a * 'a list
let of_list lst = List.(hd lst, tl lst) let of_list lst = List.hd lst, List.tl lst
let to_list (hd, tl : _ t) = hd :: tl let to_list (hd, tl : _ t) = hd :: tl
let singleton hd : 'a t = hd , [] let singleton hd : 'a t = hd , []
let hd : 'a t -> 'a = fst let hd : 'a t -> 'a = fst