From 6cc17f9a3f9d1ba94ffb837fc2261a78fbebcda8 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Fri, 6 Dec 2019 11:49:19 +0100 Subject: [PATCH] I rewrote some comments so [dune build @doc] can extract HTML from 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]. --- vendors/ligo-utils/simple-utils/pos.mli | 97 ++-- vendors/ligo-utils/simple-utils/region.ml | 8 + vendors/ligo-utils/simple-utils/region.mli | 177 ++++--- vendors/ligo-utils/simple-utils/trace.ml | 588 ++++++++++----------- vendors/ligo-utils/simple-utils/x_list.ml | 2 +- 5 files changed, 453 insertions(+), 419 deletions(-) diff --git a/vendors/ligo-utils/simple-utils/pos.mli b/vendors/ligo-utils/simple-utils/pos.mli index 77c259724..dbeb3eeab 100644 --- a/vendors/ligo-utils/simple-utils/pos.mli +++ b/vendors/ligo-utils/simple-utils/pos.mli @@ -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 diff --git a/vendors/ligo-utils/simple-utils/region.ml b/vendors/ligo-utils/simple-utils/region.ml index fb746b899..a0c41b404 100644 --- a/vendors/ligo-utils/simple-utils/region.ml +++ b/vendors/ligo-utils/simple-utils/region.ml @@ -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 *) diff --git a/vendors/ligo-utils/simple-utils/region.mli b/vendors/ligo-utils/simple-utils/region.mli index 2dc6555a2..a2f77c057 100644 --- a/vendors/ligo-utils/simple-utils/region.mli +++ b/vendors/ligo-utils/simple-utils/region.mli @@ -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 diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 04f8b511d..7464d8fb1 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -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 -> @@ -625,7 +622,7 @@ let bind_fold_pair f init (a,b) = in List.fold_left aux (ok init) [a;b] -let bind_fold_triple f init (a,b,c) = +let bind_fold_triple f init (a,b,c) = let aux x y = x >>? fun x -> f x y @@ -847,4 +844,3 @@ let errors_pp_short = Format.pp_print_list ~pp_sep:Format.pp_print_newline error_pp_short - diff --git a/vendors/ligo-utils/simple-utils/x_list.ml b/vendors/ligo-utils/simple-utils/x_list.ml index 7c856146e..19bf881a5 100644 --- a/vendors/ligo-utils/simple-utils/x_list.ml +++ b/vendors/ligo-utils/simple-utils/x_list.ml @@ -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