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 committed by Christian Rinderknecht
parent 3d9971c909
commit 6cc17f9a3f
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
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
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
(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
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].
*)
{ul
{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 = <
(* Payload *)
@ -39,43 +74,16 @@ type 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;
offset : [`Byte | `Point] -> int;
column : [`Byte | `Point] -> int;
line_offset : [`Byte | `Point] -> int;
byte_offset : int;
@ -90,19 +98,26 @@ type t = <
anonymous : ?offsets:bool -> [`Byte | `Point] -> string
>
(** A shorthand after an [open Pos].
*)
type pos = t
(* Constructors *)
(** {1 Constructors} *)
val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t
val from_byte : Lexing.position -> t
(* Special positions *)
(** {1 Special positions} *)
val ghost : t (* Same as [Lexing.dummy_pos] *)
val min : t (* Lexing convention: line 1, offsets to 0 and file to "". *)
(** The value [ghost] is the same as {! Lexing.dummy_pos}.
*)
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 lt : t -> t -> bool

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

@ -1,7 +1,11 @@
(* Regions of a file *)
(* A shorthand *)
let sprintf = Printf.sprintf
(* The object type for regions *)
type t = <
start : Pos.t;
stop : Pos.t;
@ -28,8 +32,12 @@ type t = <
compact : ?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string
>
(* A synonym *)
type region = t
(* A convenience *)
type 'a reg = {region: t; value: 'a}
(* 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
file. It is here denoted by the object type [t].
A {e 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.
(** {1 Definition} *)
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.
*)
(** The start (included) of the region is given by the field [start],
which is a {e 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], 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 = <
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;
@ -47,84 +76,70 @@ type t = <
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.
*)
(* Conversions to type [string] *)
to_string : ?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
(** 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}
(* 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. *)
(* {1 Constructors} *)
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
(* Special regions *)
(** {1 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 *)
(* This wraps a value with a ghost region. *)
(** To deal with ghost expressions, that is, pieces of abstract syntax
that have not been built from excerpts of concrete syntax, we need
{e 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. It is implemented as two [Pos.ghost]
positions. *)
val ghost : t
(** The call to [wrap_ghost] wraps a value within a ghost region.
*)
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
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. *)
(** {1 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].) *)
(** 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]. *)
(** Given two regions [r1] and [r2], we may want the region [cover r1
r2] that covers [r1] and [r2]. We have the 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

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

@ -1,355 +1,360 @@
(** Trace tutorial
The module below guides the reader through the writing of a
simplified version of the trace monad (`result`), and the
definition of a few operations that make it easier to work with
`result`.
This module guides the reader through the writing of a simplified
version of the trace monad [result], and the definition of a few
operations that make it easier to work with [result].
*)
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 =
Some of 'a (* Ok also stores a list of annotations *)
| None;; (* Errors also stores a list of messages *)
type annotation = string
type error = string
type annotation = string;;
type error = string;;
type 'a result =
(** The type ['a result] is used by the trace monad to both model an
expected value of type ['a] or the failure to obtain it, instead
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
| Errors of error list;;
| Errors of error list
(** When applying a partial function on a result, it can return a valid result
(Some v), or indicate failure (None). *)
(** The function [divide_trace] shows the basic use of the trace
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 =
if b = 0
then None
else Some (a/b);;
(** The function [divide_three] shows that when composing two
functions, if the first call fails, the error is passed along
and the second call is not evaluated. (A pattern called
"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 failure, to ease debugging. *)
(** The function [divide_three_annot] shows that when composing two
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 =
if b = 0
then (Errors [Printf.sprintf "division by zero: %d / %d" a b])
else Ok ((a/b) , []);;
(** The systematic matching of the result of each call in a function
composition is bulky, so we define a [bind] function which takes
a function [f: 'a -> 'b result] and applies it to a current ['a
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 =
let maybe_a_div_b = divide_trace a b in
match maybe_a_div_b with
Ok (a_div_b , _) -> divide_trace a_div_b c
| (Errors _) as e -> e;;
(** The function [divide_three_bind] is equivalent to the verbose
[divide_three] above, but makes use of [bind].
*)
let divide_three_bind a b c =
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 =
let maybe_a_div_b = divide_trace a b in
match maybe_a_div_b with
Ok (a_div_b , annots1) ->
let maybe_a_div_b_div_c = divide_trace a_div_b c in
begin
match maybe_a_div_b_div_c with
Ok (a_div_b_div_c , annots2)
-> Ok (a_div_b_div_c , annots2 @ annots1)
| (Errors _) as e2 -> e2
end
| (Errors _) as e1 -> e1;;
(** The function [divide_three_bind_symbol] is equivalent to
[divide_three_bind], but makes use of the operator [(>>?)].
*)
let divide_three_bind_symbol a b c =
let maybe_a_div_b = divide_trace a b in
let continuation a_div_b = divide_trace a_div_b c in
maybe_a_div_b >>? continuation
(** This incurs quite a lot of noise, so we define a `bind` operator which
takes a function ('x -> ('y result)) and applies it to an existing
('x result).
(** The function [divide_three_bind_symbol'] is equivalent to
[divide_three_bind_symbol], where the two temporary [let]
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
calling the function
* Otherwise `bind` unwraps the Ok and calls the function
* That function may itself return an error
* Otherwise `bind` combines the annotations and returns the second
result. *)
(** This is now fairly legible, but chaining many such functions is
not the usual way of writing code. We use the PPX extension to
the OCaml compiler [ppx_let] to add some syntactic sugar.
The extension framework 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], 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
| Ok (x, annotations) ->
(match f x with
Ok (x', annotations') -> Ok (x', annotations' @ annotations)
| Errors _ as e' -> ignore annotations; e')
| Errors _ as e -> e;;
(** The function [divide_three_bind_ppx_let] is equivalent to the
function [divide_three_bind_symbol']. The only difference is
that the module [Open_on_rhs_bind] is implicitly 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
(** The following function divide_three_bind is equivalent to the verbose
divide_three. *)
(** The function [divide_many_bind_ppx_let] shows how well this
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 =
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;;
(** The function [ok] is a shorthand for an [Ok] without
annotations.
*)
let ok x = Ok (x, [])
(** This made the code shorter, but the reading order is a bit awkward.
We define an operator symbol for `bind`: *)
(** The function [map] lifts a regular ['a -> 'b] function on values to
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 =
let maybe_a_div_b = divide_trace a b in
let continuation a_div_b = divide_trace a_div_b c in
maybe_a_div_b >>? continuation;;
(** and we inline the two temporary let definitions: *)
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.";;
(** 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 generated lazily.
*)
let the_end = "End of the tutorial."
end (* end Trace_tutorial. *)
module J = Yojson.Basic
module JSON_string_utils = struct
let member = fun n x ->
let member n x =
match x with
| `Null -> `Null
`Null -> `Null
| x -> J.Util.member n x
let string = J.Util.to_string_option
let to_list_option = fun x ->
try ( Some (J.Util.to_list x))
with _ -> None
try Some (J.Util.to_list x) with _ -> None
let to_assoc_option = fun x ->
try ( Some (J.Util.to_assoc x))
with _ -> None
try Some (J.Util.to_assoc x) with _ -> None
let list = to_list_option
let assoc = to_assoc_option
let int = J.Util.to_int_option
let patch j k v =
match assoc j with
| None -> j
None -> j
| 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 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
let bind2 f 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
Some x -> x
| None -> d
let string_of_int = bind string_of_int
let (||) l r = l |> default r
let (|^) = bind2 (^)
end
type 'a thunk = unit -> 'a
(**
Errors are encoded in JSON. This is because different libraries will
implement their own helpers, and we don't want to hardcode in their type how
they are supposed to interact.
*)
(** Errors are encoded in JSON. This is because different libraries
will implement their own helpers, and we do not want to hardcode
in their type how they are supposed to interact.
*)
type error = J.t
(**
Thunks are used because computing some errors can be costly, and we don't
to spend most of our time building errors. Instead, their computation is
deferred.
*)
(** Thunks are used because computing some errors can be costly, and
we do not want to spend most of our time building errors. Instead,
their computation is deferred.
*)
type error_thunk = error thunk
(**
Annotations should be used in debug mode to aggregate information about some
value history. Where it was produced, when it was modified, etc.
It's currently not being used.
*)
(** Annotations should be used in debug mode to aggregate information
about some value history. Where it was produced, when it was
modified, etc. It is currently not being used. *)
type annotation = J.t
(**
Even in debug mode, building annotations can be quite resource-intensive.
Instead, a thunk is passed, that is computed only when debug information is
queried (typically before a print).
*)
(** Even in debug mode, building annotations can be quite
resource-intensive. Instead, a thunk is passed, that is computed
only when debug information is queried (typically before a print).
*)
type annotation_thunk = annotation thunk
(**
Types of traced elements. It might be good to rename it `trace` at some
point.
*)
(** Types of traced elements. It might be good to rename it [trace] at
some point.
*)
type 'a result =
| Ok of 'a * annotation_thunk list
| Error of error_thunk
Ok of 'a * annotation_thunk list
| Error of error_thunk
(**
Constructors
*)
(** {1 Constructors} *)
let ok x = Ok (x, [])
let fail err = Error err
(**
Monadic operators
*)
(** {1 Monadic operators} *)
let bind f = function
| Ok (x, annotations) ->
(match f x with
Ok (x', annotations') -> Ok (x', annotations' @ annotations)
| Error _ as e' -> ignore annotations; e')
| Error _ as e -> e
Ok (x, ann) -> (
match f x with
Ok (x', ann') -> Ok (x', ann' @ ann)
| Error _ as e' -> ignore ann; e')
| Error _ as e -> e
let map f = function
| Ok (x, annotations) -> Ok (f x, annotations)
| Error _ as e -> e
Ok (x, annotations) -> Ok (f x, annotations)
| Error _ as e -> e
(**
Usual bind-syntax is `>>=`, but this is taken from the Tezos code base. Where
the `result` bind is `>>?`, Lwt's (threading library) is `>>=`, and the
combination of both is `>>=?`.
*)
let (>>?) x f = bind f x
(** The lexical convention usually adopted for the bind function is
[>>=], but ours comes from the Tezos code base, where the [result]
bind is [>>?], and [Lwt]'s (threading library) is [>>=], and the
combination of both is [>>=?].
*)
let (>>?) x f = bind f x
let (>>|?) x f = map f x
(**
Used by PPX_let, an OCaml preprocessor.
What it does is that, when you only care about the case where a result isn't
an error, instead of writing:
```
[
(* Stuff that might return an error *) >>? fun ok_value ->
(* Stuff being done on the result *)
```
]
You can write:
```
[
let%bind ok_value = (* Stuff that might return an error *) in
(* Stuff being done on the result *)
```
This is much more typical of OCaml. makes the code more readable, easy to
write and refactor. It is used pervasively in LIGO.
*)
]
This is much more typical of OCaml. This makes the code more
readable, easy to write and refactor. It is used pervasively in
LIGO.
*)
module Let_syntax = struct
let bind m ~f = m >>? f
module Open_on_rhs_bind = struct end
end
(**
Build a thunk from a constant.
*)
(** Build a thunk from a constant.
*)
let thunk x () = x
(**
Build a standard error, with a title, a message, an error code and some data.
*)
(** Build a standard error, with a title, a message, an error code and
some data.
*)
let mk_error
?(error_code : int thunk option) ?(message : string thunk option)
?(data : (string * string thunk) list option)
@ -407,48 +412,42 @@ let prepend_info = fun info err ->
patch err "infos" (`List infos)
(**
Helpers that ideally shouldn't be used in production.
(** Helpers that ideally should not be used in production.
*)
let simple_error str () = mk_error ~title:(thunk str) ()
let simple_info str () = mk_info ~title:(thunk str) ()
let simple_fail str = fail @@ simple_error 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 when
followed by `trace_strong`.
*)
(** To be used when you only want to signal an error. It can be useful
when followed by [trace_strong].
*)
let dummy_fail = simple_fail "dummy"
let trace info = function
| Ok _ as o -> o
| Error err -> Error (fun () -> prepend_info (info ()) (err ()))
Ok _ as o -> o
| Error err -> Error (fun () -> prepend_info (info ()) (err ()))
(**
Erase the current error stack, and replace it by the given error. It's useful
when using `Assert` and you want to discard its auto-generated message.
*)
(** Erase the current error stack, and replace it by the given
error. It's useful when using [Assert] and you want to discard its
autogenerated message.
*)
let trace_strong err = function
| Ok _ as o -> o
| Error _ -> Error err
Ok _ as o -> o
| Error _ -> Error err
(**
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:
```
let type_list lst =
[let type_list lst =
let%bind lst' =
trace_list (simple_error "Error while typing a list") @@
List.map type_element lst in
...
```
...]
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 trace_list err lst =
let oks =
@ -520,18 +519,16 @@ let trace_option error = function
| None -> fail error
| Some s -> ok s
(**
Utilities to interact with other data-structure.
`bind_t` takes an `'a result t` and makes a `'a t result` out of it. It
"lifts" the error out of the type.
The most common context is when mapping a given type. For instance, if you
use a function that can fail in `List.map`, you need to manage a whole list
of results. Instead, you do `let%bind lst' = bind_list @@ List.map f lst`,
which will yield an `'a list`.
`bind_map_t` is roughly syntactic sugar for `bind_t @@ T.map`. So that you
can rewrite the previous example as `let%bind lst' = bind_map_list f lst`.
Same thing with folds.
*)
(** Utilities to interact with other data-structure. [bind_t] takes
an ['a result t] and makes a ['a t result] out of it. It "lifts" the
error out of the type. The most common context is when mapping a
given type. For instance, if you use a function that can fail in
[List.map], you need to manage a whole list of results. Instead,
you do [let%bind lst' = bind_list @@ List.map f lst], which will
yield an ['a list]. [bind_map_t] is roughly syntactic sugar for
[bind_t @@ T.map]. So that you can rewrite the previous example as
[let%bind lst' = bind_map_list f lst]. Same thing with folds.
*)
let bind_map_option f = function
| 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 aux k v prev =
prev >>? fun prev' ->
f prev' k v
in
X_map.String.fold aux smap init
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)
@ -573,6 +568,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) =
ok @@ (l1' @ l2')
let bind_map_list f lst = bind_list (List.map f lst)
let rec bind_map_list_seq f lst = match lst with
| [] -> ok []
| 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
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_iter_list : (_ -> unit result) -> _ list -> unit result = fun f lst ->
bind_map_list f lst >>? fun _ -> ok ()
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 ->
@ -847,4 +844,3 @@ let errors_pp_short =
Format.pp_print_list
~pp_sep:Format.pp_print_newline
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
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 singleton hd : 'a t = hd , []
let hd : 'a t -> 'a = fst