From 09875cf1da7fb2444e24ba3681c2451af3cd96f3 Mon Sep 17 00:00:00 2001 From: Sander Spies Date: Mon, 16 Dec 2019 14:54:12 +0100 Subject: [PATCH 01/32] Make type_expr_simple less complicated. --- src/passes/1-parser/reasonligo/Parser.mly | 30 ++++++----------------- 1 file changed, 7 insertions(+), 23 deletions(-) diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index c91cd352e..61edd2349 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -388,30 +388,14 @@ type_expr_simple_args: par(nsepseq(type_expr_simple, ",")) { $1 } type_expr_simple: - core_expr_2 type_expr_simple_args? { + type_name type_expr_simple_args? { let args = $2 in - let constr = - match $1 with - EVar i -> i - | EProj {value={struct_name; field_path; _}; region} -> - let app a = function - FieldName v -> a ^ "." ^ v.value - | Component {value = c, _; _} -> a ^ "." ^ c in - let value = - Utils.nsepseq_foldl app struct_name.value field_path - in {region; value} - | EArith Mutez r | EArith Int r | EArith Nat r -> - {r with value = fst r.value} - | EString String s -> s - | ELogic BoolExpr (True t) -> {region=t; value="true"} - | ELogic BoolExpr (False f) -> {region=f; value="false"} - | _ -> failwith "Not supported" (* TODO: raise a proper exception *) - in match args with - Some {value; _} -> - let region = cover (expr_to_region $1) value.rpar in - let value = constr, {region; value} - in TApp {region; value} - | None -> TVar constr + match args with + Some {value; _} -> + let region = cover $1.region value.rpar in + let value = $1, {region; value} + in TApp {region; value} + | None -> TVar $1 } | "(" nsepseq(type_expr_simple, ",") ")" { TProd {region = cover $1 $3; value=$2} From 257ef4f5d220839181c3d1c116a9065e366e3382 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Mon, 16 Dec 2019 17:37:46 +0100 Subject: [PATCH 02/32] Added unlexer for PascaLIGO. --- src/passes/1-parser/pascaligo/.Parser.mly.tag | 2 +- src/passes/1-parser/pascaligo/.unlexer.tag | 0 src/passes/1-parser/pascaligo/unlexer.ml | 121 ++++++++++++++++++ 3 files changed, 122 insertions(+), 1 deletion(-) create mode 100644 src/passes/1-parser/pascaligo/.unlexer.tag create mode 100644 src/passes/1-parser/pascaligo/unlexer.ml diff --git a/src/passes/1-parser/pascaligo/.Parser.mly.tag b/src/passes/1-parser/pascaligo/.Parser.mly.tag index 100f7bb69..ab6790b0f 100644 --- a/src/passes/1-parser/pascaligo/.Parser.mly.tag +++ b/src/passes/1-parser/pascaligo/.Parser.mly.tag @@ -1 +1 @@ ---explain --external-tokens LexToken --base Parser ParToken.mly +--table --explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/passes/1-parser/pascaligo/.unlexer.tag b/src/passes/1-parser/pascaligo/.unlexer.tag new file mode 100644 index 000000000..e69de29bb diff --git a/src/passes/1-parser/pascaligo/unlexer.ml b/src/passes/1-parser/pascaligo/unlexer.ml new file mode 100644 index 000000000..0ee7da436 --- /dev/null +++ b/src/passes/1-parser/pascaligo/unlexer.ml @@ -0,0 +1,121 @@ +(** Converting the textual representation of tokens produced by Menhir + into concrete syntax *) + +(* See [ParToken.mly] *) + +let gen_sym prefix = + let count = ref 0 in + fun () -> incr count; + prefix ^ string_of_int !count + +let id_sym = gen_sym "id" +and ctor_sym = gen_sym "C" + +let concrete = function + (* Keywords *) + + "And" -> "and" +| "Begin" -> "begin" +| "BigMap" -> "big_map" +| "Block" -> "block" +| "Case" -> "case" +| "Const" -> "const" +| "Contains" -> "contains" +| "Else" -> "else" +| "End" -> "end" +| "False" -> "False" +| "For" -> "for" +| "Function" -> "function" +| "From" -> "from" +| "If" -> "if" +| "In" -> "in" +| "Is" -> "is" +| "List" -> "list" +| "Map" -> "map" +| "Mod" -> "mod" +| "Nil" -> "nil" +| "Not" -> "not" +| "Of" -> "of" +| "Or" -> "or" +| "Patch" -> "patch" +| "Record" -> "record" +| "Remove" -> "remove" +| "Set" -> "set" +| "Skip" -> "skip" +| "Then" -> "then" +| "To" -> "to" +| "True" -> "True" +| "Type" -> "type" +| "Unit" -> "Unit" +| "Var" -> "var" +| "While" -> "while" +| "With" -> "with" + + (* Data constructors *) + +| "C_None" -> "None" +| "C_Some" -> "Some" + + (* Symbols *) + +| "SEMI" -> ";" +| "COMMA" -> "," +| "LPAR" -> "(" +| "RPAR" -> ")" +| "LBRACE" -> "{" +| "RBRACE" -> "}" +| "LBRACKET" -> "[" +| "RBRACKET" -> "]" +| "CONS" -> "#" +| "VBAR" -> "|" +| "ARROW" -> "->" +| "ASS" -> ":=" +| "EQ" -> "=" +| "COLON" -> ":" +| "LT" -> "<" +| "LE" -> "<=" +| "GT" -> ">" +| "GE" -> ">=" +| "NE" -> "=/=" +| "PLUS" -> "+" +| "MINUS" -> " -" +| "SLASH" -> "/" +| "TIMES" -> "*" +| "DOT" -> "." +| "WILD" -> "_" +| "CAT" -> "^" + + (* Literals *) + +| "String" -> "\"a string\"" +| "Bytes" -> "0xAA" +| "Int" -> "1" +| "Nat" -> "1n" +| "Mutez" -> "1mutez" +| "Ident" -> id_sym () +| "Constr" -> ctor_sym () + + (* Virtual tokens *) + +| "EOF" -> "" + + (* For completeness of open sum types *) + +| _ -> "" + +(* Unlexing a sentence *) + +let unlex (sentence: string) : Buffer.t = + let tokens = Str.split (Str.regexp " ") sentence in + let lexemes = List.map concrete tokens in + let buffer = Buffer.create 31 in + let rec trans = function + [] -> () + | [s] -> Buffer.add_string buffer s + | s::l -> Buffer.add_string buffer (s ^ " "); trans l + in trans lexemes; buffer + +(* Reading one line from the standard input channel and unlex it. *) + +let out = unlex (input_line stdin) |> Buffer.contents +let () = Printf.printf "%s\n" out From 52eff4e764a29694e6a9048981352c654aee93db Mon Sep 17 00:00:00 2001 From: Sander Spies Date: Mon, 16 Dec 2019 15:52:45 +0100 Subject: [PATCH 03/32] Incorrect function arguments message for ReasonLIGO. --- src/passes/1-parser/dune | 2 +- src/passes/1-parser/reasonligo.ml | 13 ++++++++++++- src/passes/1-parser/reasonligo/Parser.mly | 8 ++++---- src/passes/1-parser/shared/SyntaxError.ml | 4 ++++ src/passes/1-parser/shared/SyntaxError.mli | 4 ++++ src/passes/1-parser/shared/dune | 1 + 6 files changed, 26 insertions(+), 6 deletions(-) create mode 100644 src/passes/1-parser/shared/SyntaxError.ml create mode 100644 src/passes/1-parser/shared/SyntaxError.mli diff --git a/src/passes/1-parser/dune b/src/passes/1-parser/dune index 9a4f86a94..8e478b392 100644 --- a/src/passes/1-parser/dune +++ b/src/passes/1-parser/dune @@ -12,5 +12,5 @@ (preprocess (pps ppx_let) ) - (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared )) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared)) ) diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index 8fafc5c95..a3b52b110 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -22,7 +22,18 @@ let parse_file (source: string) : AST.t result = let lexbuf = Lexing.from_channel channel in let Lexer.{read ; close ; _} = Lexer.open_token_stream None in - specific_try (function + specific_try (function + | SyntaxError.Error WrongFunctionArguments -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + let str = Format.sprintf + "Incorrect function arguments at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" + (Lexing.lexeme lexbuf) + start.pos_lnum (start.pos_cnum - start.pos_bol) + end_.pos_lnum (end_.pos_cnum - end_.pos_bol) + start.pos_fname source + in + simple_error str | Parser.Error -> ( let start = Lexing.lexeme_start_p lexbuf in let end_ = Lexing.lexeme_end_p lexbuf in diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 61edd2349..444d12212 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -424,8 +424,8 @@ fun_expr: {p.value with inside = arg_to_pattern p.value.inside} in PPar {p with value} | EUnit u -> PUnit u - | _ -> failwith "Not supported" in (* TODO: raise a proper exception *) - + | _ -> raise (SyntaxError.Error WrongFunctionArguments) + in let fun_args_to_pattern = function EAnnot { value = { @@ -453,8 +453,8 @@ fun_expr: in arg_to_pattern (fst fun_args), bindings | EUnit e -> arg_to_pattern (EUnit e), [] - | _ -> failwith "Not supported" in (* TODO: raise a proper exception *) - + | _ -> raise (SyntaxError.Error WrongFunctionArguments) + in let binders = fun_args_to_pattern $1 in let f = {kwd_fun; binders; diff --git a/src/passes/1-parser/shared/SyntaxError.ml b/src/passes/1-parser/shared/SyntaxError.ml new file mode 100644 index 000000000..a0faa0bbb --- /dev/null +++ b/src/passes/1-parser/shared/SyntaxError.ml @@ -0,0 +1,4 @@ +type error = + | WrongFunctionArguments + +exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/shared/SyntaxError.mli b/src/passes/1-parser/shared/SyntaxError.mli new file mode 100644 index 000000000..a0faa0bbb --- /dev/null +++ b/src/passes/1-parser/shared/SyntaxError.mli @@ -0,0 +1,4 @@ +type error = + | WrongFunctionArguments + +exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 3d763b1df..0da93bc70 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -18,6 +18,7 @@ FQueue EvalOpt Version + SyntaxError ) (modules_without_implementation Error) ) From 35d4b64a029732ade0346b053e3f0433d49cd69d Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Tue, 17 Dec 2019 14:56:16 +0100 Subject: [PATCH 04/32] Removed the open type [Error.t] (less [assert false]). I also had to remove the keywords [Down], [Fail] and [Step] in PascaLIGO that made a mysterious and unwanted come back. (I did not bother with [git blame]). --- src/passes/1-parser/cameligo/.links | 1 - src/passes/1-parser/cameligo/ParserMain.ml | 11 +++--- src/passes/1-parser/pascaligo/.links | 1 - src/passes/1-parser/pascaligo/LexToken.mli | 3 -- src/passes/1-parser/pascaligo/LexToken.mll | 15 ------- src/passes/1-parser/pascaligo/ParserMain.ml | 11 +++--- src/passes/1-parser/reasonligo/.links | 1 - src/passes/1-parser/reasonligo/ParserMain.ml | 11 +++--- src/passes/1-parser/shared/Error.mli | 3 -- src/passes/1-parser/shared/Lexer.mli | 6 ++- src/passes/1-parser/shared/Lexer.mll | 41 ++++++++++---------- src/passes/1-parser/shared/dune | 9 +---- 12 files changed, 42 insertions(+), 71 deletions(-) delete mode 100644 src/passes/1-parser/shared/Error.mli diff --git a/src/passes/1-parser/cameligo/.links b/src/passes/1-parser/cameligo/.links index f0fdfb646..eca6c8680 100644 --- a/src/passes/1-parser/cameligo/.links +++ b/src/passes/1-parser/cameligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index e683b15d1..e1e35850b 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links index f0fdfb646..eca6c8680 100644 --- a/src/passes/1-parser/pascaligo/.links +++ b/src/passes/1-parser/pascaligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/pascaligo/LexToken.mli b/src/passes/1-parser/pascaligo/LexToken.mli index b1865faad..aa906f8d8 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mli +++ b/src/passes/1-parser/pascaligo/LexToken.mli @@ -77,10 +77,8 @@ type t = | Case of Region.t (* "case" *) | Const of Region.t (* "const" *) | Contains of Region.t (* "contains" *) -| Down of Region.t (* "down" *) | Else of Region.t (* "else" *) | End of Region.t (* "end" *) -| Fail of Region.t (* "fail" *) | False of Region.t (* "False" *) | For of Region.t (* "for" *) | From of Region.t (* "from" *) @@ -100,7 +98,6 @@ type t = | Remove of Region.t (* "remove" *) | Set of Region.t (* "set" *) | Skip of Region.t (* "skip" *) -| Step of Region.t (* "step" *) | Then of Region.t (* "then" *) | To of Region.t (* "to" *) | True of Region.t (* "True" *) diff --git a/src/passes/1-parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll index 67d2c0ed9..16f4dd96a 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mll +++ b/src/passes/1-parser/pascaligo/LexToken.mll @@ -75,10 +75,8 @@ type t = | Case of Region.t (* "case" *) | Const of Region.t (* "const" *) | Contains of Region.t (* "contains" *) -| Down of Region.t (* "down" *) | Else of Region.t (* "else" *) | End of Region.t (* "end" *) -| Fail of Region.t (* "fail" *) | False of Region.t (* "False" *) | For of Region.t (* "for" *) | From of Region.t (* "from" *) @@ -98,7 +96,6 @@ type t = | Remove of Region.t (* "remove" *) | Set of Region.t (* "set" *) | Skip of Region.t (* "skip" *) -| Step of Region.t (* "step" *) | Then of Region.t (* "then" *) | To of Region.t (* "to" *) | True of Region.t (* "True" *) @@ -184,10 +181,8 @@ let proj_token = function | Case region -> region, "Case" | Const region -> region, "Const" | Contains region -> region, "Contains" -| Down region -> region, "Down" | Else region -> region, "Else" | End region -> region, "End" -| Fail region -> region, "Fail" | False region -> region, "False" | For region -> region, "For" | From region -> region, "From" @@ -207,7 +202,6 @@ let proj_token = function | Remove region -> region, "Remove" | Set region -> region, "Set" | Skip region -> region, "Skip" -| Step region -> region, "Step" | Then region -> region, "Then" | To region -> region, "To" | True region -> region, "True" @@ -276,10 +270,8 @@ let to_lexeme = function | Case _ -> "case" | Const _ -> "const" | Contains _ -> "contains" -| Down _ -> "down" | Else _ -> "else" | End _ -> "end" -| Fail _ -> "fail" | False _ -> "False" | For _ -> "for" | From _ -> "from" @@ -299,7 +291,6 @@ let to_lexeme = function | Remove _ -> "remove" | Set _ -> "set" | Skip _ -> "skip" -| Step _ -> "step" | Then _ -> "then" | To _ -> "to" | True _ -> "True" @@ -336,13 +327,11 @@ let keywords = [ (fun reg -> Case reg); (fun reg -> Const reg); (fun reg -> Contains reg); - (fun reg -> Down reg); (fun reg -> Else reg); (fun reg -> End reg); (fun reg -> For reg); (fun reg -> From reg); (fun reg -> Function reg); - (fun reg -> Fail reg); (fun reg -> False reg); (fun reg -> If reg); (fun reg -> In reg); @@ -360,7 +349,6 @@ let keywords = [ (fun reg -> Remove reg); (fun reg -> Set reg); (fun reg -> Skip reg); - (fun reg -> Step reg); (fun reg -> Then reg); (fun reg -> To reg); (fun reg -> True reg); @@ -560,10 +548,8 @@ let is_kwd = function | Case _ | Const _ | Contains _ -| Down _ | Else _ | End _ -| Fail _ | False _ | For _ | From _ @@ -583,7 +569,6 @@ let is_kwd = function | Remove _ | Set _ | Skip _ -| Step _ | Then _ | To _ | True _ diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 130cfbb23..295d460d8 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/reasonligo/.links b/src/passes/1-parser/reasonligo/.links index 09ca1c65f..e827ae13e 100644 --- a/src/passes/1-parser/reasonligo/.links +++ b/src/passes/1-parser/reasonligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/reasonligo/ParserMain.ml b/src/passes/1-parser/reasonligo/ParserMain.ml index 30fd040dd..f4e8058cd 100644 --- a/src/passes/1-parser/reasonligo/ParserMain.ml +++ b/src/passes/1-parser/reasonligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/shared/Error.mli b/src/passes/1-parser/shared/Error.mli deleted file mode 100644 index 19c1ce4c9..000000000 --- a/src/passes/1-parser/shared/Error.mli +++ /dev/null @@ -1,3 +0,0 @@ -type t = .. - -type error = t diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index cc0359998..50754e45f 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -136,11 +136,13 @@ module type S = (* Error reporting *) - exception Error of Error.t Region.reg + type error + + exception Error of error Region.reg val print_error : ?offsets:bool -> [`Byte | `Point] -> - Error.t Region.reg -> file:bool -> unit + error Region.reg -> file:bool -> unit end diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 41d95b432..1e8e382fa 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -159,10 +159,11 @@ module type S = sig (* Error reporting *) - exception Error of Error.t Region.reg + type error + exception Error of error Region.reg val print_error : ?offsets:bool -> [`Byte | `Point] -> - Error.t Region.reg -> file:bool -> unit + error Region.reg -> file:bool -> unit end (* The functorised interface @@ -330,22 +331,23 @@ module Make (Token: TOKEN) : (S with module Token = Token) = (* ERRORS *) - type Error.t += Invalid_utf8_sequence - type Error.t += Unexpected_character of char - type Error.t += Undefined_escape_sequence - type Error.t += Missing_break - type Error.t += Unterminated_string - type Error.t += Unterminated_integer - type Error.t += Odd_lengthed_bytes - type Error.t += Unterminated_comment - type Error.t += Orphan_minus - type Error.t += Non_canonical_zero - type Error.t += Negative_byte_sequence - type Error.t += Broken_string - type Error.t += Invalid_character_in_string - type Error.t += Reserved_name - type Error.t += Invalid_symbol - type Error.t += Invalid_natural + type error = + Invalid_utf8_sequence + | Unexpected_character of char + | Undefined_escape_sequence + | Missing_break + | Unterminated_string + | Unterminated_integer + | Odd_lengthed_bytes + | Unterminated_comment + | Orphan_minus + | Non_canonical_zero + | Negative_byte_sequence + | Broken_string + | Invalid_character_in_string + | Reserved_name + | Invalid_symbol + | Invalid_natural let error_to_string = function Invalid_utf8_sequence -> @@ -393,9 +395,8 @@ module Make (Token: TOKEN) : (S with module Token = Token) = Hint: Check the LIGO syntax you use.\n" | Invalid_natural -> "Invalid natural." - | _ -> assert false - exception Error of Error.t Region.reg + exception Error of error Region.reg let print_error ?(offsets=true) mode Region.{region; value} ~file = let msg = error_to_string value in diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 3d763b1df..2dafdbd17 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -7,20 +7,15 @@ simple-utils uutf getopt - zarith - ) + zarith) (modules - Error Lexer LexerLog Utils Markup FQueue EvalOpt - Version - ) - (modules_without_implementation Error) -) + Version)) (rule (targets Version.ml) From 531dd238a78bba45f1a2cb08822da74a9a095cd0 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Mon, 16 Dec 2019 17:37:46 +0100 Subject: [PATCH 05/32] Added unlexer for PascaLIGO. --- src/passes/1-parser/pascaligo/.Parser.mly.tag | 2 +- src/passes/1-parser/pascaligo/.unlexer.tag | 0 src/passes/1-parser/pascaligo/unlexer.ml | 121 ++++++++++++++++++ 3 files changed, 122 insertions(+), 1 deletion(-) create mode 100644 src/passes/1-parser/pascaligo/.unlexer.tag create mode 100644 src/passes/1-parser/pascaligo/unlexer.ml diff --git a/src/passes/1-parser/pascaligo/.Parser.mly.tag b/src/passes/1-parser/pascaligo/.Parser.mly.tag index 100f7bb69..ab6790b0f 100644 --- a/src/passes/1-parser/pascaligo/.Parser.mly.tag +++ b/src/passes/1-parser/pascaligo/.Parser.mly.tag @@ -1 +1 @@ ---explain --external-tokens LexToken --base Parser ParToken.mly +--table --explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/passes/1-parser/pascaligo/.unlexer.tag b/src/passes/1-parser/pascaligo/.unlexer.tag new file mode 100644 index 000000000..e69de29bb diff --git a/src/passes/1-parser/pascaligo/unlexer.ml b/src/passes/1-parser/pascaligo/unlexer.ml new file mode 100644 index 000000000..0ee7da436 --- /dev/null +++ b/src/passes/1-parser/pascaligo/unlexer.ml @@ -0,0 +1,121 @@ +(** Converting the textual representation of tokens produced by Menhir + into concrete syntax *) + +(* See [ParToken.mly] *) + +let gen_sym prefix = + let count = ref 0 in + fun () -> incr count; + prefix ^ string_of_int !count + +let id_sym = gen_sym "id" +and ctor_sym = gen_sym "C" + +let concrete = function + (* Keywords *) + + "And" -> "and" +| "Begin" -> "begin" +| "BigMap" -> "big_map" +| "Block" -> "block" +| "Case" -> "case" +| "Const" -> "const" +| "Contains" -> "contains" +| "Else" -> "else" +| "End" -> "end" +| "False" -> "False" +| "For" -> "for" +| "Function" -> "function" +| "From" -> "from" +| "If" -> "if" +| "In" -> "in" +| "Is" -> "is" +| "List" -> "list" +| "Map" -> "map" +| "Mod" -> "mod" +| "Nil" -> "nil" +| "Not" -> "not" +| "Of" -> "of" +| "Or" -> "or" +| "Patch" -> "patch" +| "Record" -> "record" +| "Remove" -> "remove" +| "Set" -> "set" +| "Skip" -> "skip" +| "Then" -> "then" +| "To" -> "to" +| "True" -> "True" +| "Type" -> "type" +| "Unit" -> "Unit" +| "Var" -> "var" +| "While" -> "while" +| "With" -> "with" + + (* Data constructors *) + +| "C_None" -> "None" +| "C_Some" -> "Some" + + (* Symbols *) + +| "SEMI" -> ";" +| "COMMA" -> "," +| "LPAR" -> "(" +| "RPAR" -> ")" +| "LBRACE" -> "{" +| "RBRACE" -> "}" +| "LBRACKET" -> "[" +| "RBRACKET" -> "]" +| "CONS" -> "#" +| "VBAR" -> "|" +| "ARROW" -> "->" +| "ASS" -> ":=" +| "EQ" -> "=" +| "COLON" -> ":" +| "LT" -> "<" +| "LE" -> "<=" +| "GT" -> ">" +| "GE" -> ">=" +| "NE" -> "=/=" +| "PLUS" -> "+" +| "MINUS" -> " -" +| "SLASH" -> "/" +| "TIMES" -> "*" +| "DOT" -> "." +| "WILD" -> "_" +| "CAT" -> "^" + + (* Literals *) + +| "String" -> "\"a string\"" +| "Bytes" -> "0xAA" +| "Int" -> "1" +| "Nat" -> "1n" +| "Mutez" -> "1mutez" +| "Ident" -> id_sym () +| "Constr" -> ctor_sym () + + (* Virtual tokens *) + +| "EOF" -> "" + + (* For completeness of open sum types *) + +| _ -> "" + +(* Unlexing a sentence *) + +let unlex (sentence: string) : Buffer.t = + let tokens = Str.split (Str.regexp " ") sentence in + let lexemes = List.map concrete tokens in + let buffer = Buffer.create 31 in + let rec trans = function + [] -> () + | [s] -> Buffer.add_string buffer s + | s::l -> Buffer.add_string buffer (s ^ " "); trans l + in trans lexemes; buffer + +(* Reading one line from the standard input channel and unlex it. *) + +let out = unlex (input_line stdin) |> Buffer.contents +let () = Printf.printf "%s\n" out From 757b0da78c534141d10061a834ac7615ca442b08 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Tue, 17 Dec 2019 14:56:16 +0100 Subject: [PATCH 06/32] Removed the open type [Error.t] (less [assert false]). I also had to remove the keywords [Down], [Fail] and [Step] in PascaLIGO that made a mysterious and unwanted come back. (I did not bother with [git blame]). --- src/passes/1-parser/cameligo/.links | 1 - src/passes/1-parser/cameligo/ParserMain.ml | 11 +++--- src/passes/1-parser/pascaligo/.links | 1 - src/passes/1-parser/pascaligo/LexToken.mli | 3 -- src/passes/1-parser/pascaligo/LexToken.mll | 15 ------- src/passes/1-parser/pascaligo/ParserMain.ml | 11 +++--- src/passes/1-parser/reasonligo/.links | 1 - src/passes/1-parser/reasonligo/ParserMain.ml | 11 +++--- src/passes/1-parser/shared/Error.mli | 3 -- src/passes/1-parser/shared/Lexer.mli | 6 ++- src/passes/1-parser/shared/Lexer.mll | 41 ++++++++++---------- src/passes/1-parser/shared/dune | 9 +---- 12 files changed, 42 insertions(+), 71 deletions(-) delete mode 100644 src/passes/1-parser/shared/Error.mli diff --git a/src/passes/1-parser/cameligo/.links b/src/passes/1-parser/cameligo/.links index f0fdfb646..eca6c8680 100644 --- a/src/passes/1-parser/cameligo/.links +++ b/src/passes/1-parser/cameligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index e683b15d1..e1e35850b 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/pascaligo/.links b/src/passes/1-parser/pascaligo/.links index f0fdfb646..eca6c8680 100644 --- a/src/passes/1-parser/pascaligo/.links +++ b/src/passes/1-parser/pascaligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/pascaligo/LexToken.mli b/src/passes/1-parser/pascaligo/LexToken.mli index b1865faad..aa906f8d8 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mli +++ b/src/passes/1-parser/pascaligo/LexToken.mli @@ -77,10 +77,8 @@ type t = | Case of Region.t (* "case" *) | Const of Region.t (* "const" *) | Contains of Region.t (* "contains" *) -| Down of Region.t (* "down" *) | Else of Region.t (* "else" *) | End of Region.t (* "end" *) -| Fail of Region.t (* "fail" *) | False of Region.t (* "False" *) | For of Region.t (* "for" *) | From of Region.t (* "from" *) @@ -100,7 +98,6 @@ type t = | Remove of Region.t (* "remove" *) | Set of Region.t (* "set" *) | Skip of Region.t (* "skip" *) -| Step of Region.t (* "step" *) | Then of Region.t (* "then" *) | To of Region.t (* "to" *) | True of Region.t (* "True" *) diff --git a/src/passes/1-parser/pascaligo/LexToken.mll b/src/passes/1-parser/pascaligo/LexToken.mll index 67d2c0ed9..16f4dd96a 100644 --- a/src/passes/1-parser/pascaligo/LexToken.mll +++ b/src/passes/1-parser/pascaligo/LexToken.mll @@ -75,10 +75,8 @@ type t = | Case of Region.t (* "case" *) | Const of Region.t (* "const" *) | Contains of Region.t (* "contains" *) -| Down of Region.t (* "down" *) | Else of Region.t (* "else" *) | End of Region.t (* "end" *) -| Fail of Region.t (* "fail" *) | False of Region.t (* "False" *) | For of Region.t (* "for" *) | From of Region.t (* "from" *) @@ -98,7 +96,6 @@ type t = | Remove of Region.t (* "remove" *) | Set of Region.t (* "set" *) | Skip of Region.t (* "skip" *) -| Step of Region.t (* "step" *) | Then of Region.t (* "then" *) | To of Region.t (* "to" *) | True of Region.t (* "True" *) @@ -184,10 +181,8 @@ let proj_token = function | Case region -> region, "Case" | Const region -> region, "Const" | Contains region -> region, "Contains" -| Down region -> region, "Down" | Else region -> region, "Else" | End region -> region, "End" -| Fail region -> region, "Fail" | False region -> region, "False" | For region -> region, "For" | From region -> region, "From" @@ -207,7 +202,6 @@ let proj_token = function | Remove region -> region, "Remove" | Set region -> region, "Set" | Skip region -> region, "Skip" -| Step region -> region, "Step" | Then region -> region, "Then" | To region -> region, "To" | True region -> region, "True" @@ -276,10 +270,8 @@ let to_lexeme = function | Case _ -> "case" | Const _ -> "const" | Contains _ -> "contains" -| Down _ -> "down" | Else _ -> "else" | End _ -> "end" -| Fail _ -> "fail" | False _ -> "False" | For _ -> "for" | From _ -> "from" @@ -299,7 +291,6 @@ let to_lexeme = function | Remove _ -> "remove" | Set _ -> "set" | Skip _ -> "skip" -| Step _ -> "step" | Then _ -> "then" | To _ -> "to" | True _ -> "True" @@ -336,13 +327,11 @@ let keywords = [ (fun reg -> Case reg); (fun reg -> Const reg); (fun reg -> Contains reg); - (fun reg -> Down reg); (fun reg -> Else reg); (fun reg -> End reg); (fun reg -> For reg); (fun reg -> From reg); (fun reg -> Function reg); - (fun reg -> Fail reg); (fun reg -> False reg); (fun reg -> If reg); (fun reg -> In reg); @@ -360,7 +349,6 @@ let keywords = [ (fun reg -> Remove reg); (fun reg -> Set reg); (fun reg -> Skip reg); - (fun reg -> Step reg); (fun reg -> Then reg); (fun reg -> To reg); (fun reg -> True reg); @@ -560,10 +548,8 @@ let is_kwd = function | Case _ | Const _ | Contains _ -| Down _ | Else _ | End _ -| Fail _ | False _ | For _ | From _ @@ -583,7 +569,6 @@ let is_kwd = function | Remove _ | Set _ | Skip _ -| Step _ | Then _ | To _ | True _ diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 130cfbb23..295d460d8 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/reasonligo/.links b/src/passes/1-parser/reasonligo/.links index 09ca1c65f..e827ae13e 100644 --- a/src/passes/1-parser/reasonligo/.links +++ b/src/passes/1-parser/reasonligo/.links @@ -6,7 +6,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.mli $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml ../shared/Lexer.mli ../shared/Lexer.mll -../shared/Error.mli ../shared/EvalOpt.ml ../shared/EvalOpt.mli ../shared/FQueue.ml diff --git a/src/passes/1-parser/reasonligo/ParserMain.ml b/src/passes/1-parser/reasonligo/ParserMain.ml index 30fd040dd..f4e8058cd 100644 --- a/src/passes/1-parser/reasonligo/ParserMain.ml +++ b/src/passes/1-parser/reasonligo/ParserMain.ml @@ -25,15 +25,14 @@ let () = Printexc.record_backtrace true let external_ text = Utils.highlight (Printf.sprintf "External error: %s" text); exit 1;; -type Error.t += ParseError +type error = SyntaxError let error_to_string = function - ParseError -> "Syntax error.\n" -| _ -> assert false + SyntaxError -> "Syntax error.\n" let print_error ?(offsets=true) mode Region.{region; value} ~file = - let msg = error_to_string value in - let reg = region#to_string ~file ~offsets mode in + let msg = error_to_string value + and reg = region#to_string ~file ~offsets mode in Utils.highlight (sprintf "Parse error %s:\n%s%!" reg msg) (** {1 Preprocessing the input source and opening the input channels} *) @@ -126,7 +125,7 @@ let () = options#mode err ~file | Parser.Error -> let region = get_last () in - let error = Region.{region; value=ParseError} in + let error = Region.{region; value=SyntaxError} in let () = close_all () in print_error ~offsets:options#offsets options#mode error ~file diff --git a/src/passes/1-parser/shared/Error.mli b/src/passes/1-parser/shared/Error.mli deleted file mode 100644 index 19c1ce4c9..000000000 --- a/src/passes/1-parser/shared/Error.mli +++ /dev/null @@ -1,3 +0,0 @@ -type t = .. - -type error = t diff --git a/src/passes/1-parser/shared/Lexer.mli b/src/passes/1-parser/shared/Lexer.mli index cc0359998..50754e45f 100644 --- a/src/passes/1-parser/shared/Lexer.mli +++ b/src/passes/1-parser/shared/Lexer.mli @@ -136,11 +136,13 @@ module type S = (* Error reporting *) - exception Error of Error.t Region.reg + type error + + exception Error of error Region.reg val print_error : ?offsets:bool -> [`Byte | `Point] -> - Error.t Region.reg -> file:bool -> unit + error Region.reg -> file:bool -> unit end diff --git a/src/passes/1-parser/shared/Lexer.mll b/src/passes/1-parser/shared/Lexer.mll index 41d95b432..1e8e382fa 100644 --- a/src/passes/1-parser/shared/Lexer.mll +++ b/src/passes/1-parser/shared/Lexer.mll @@ -159,10 +159,11 @@ module type S = sig (* Error reporting *) - exception Error of Error.t Region.reg + type error + exception Error of error Region.reg val print_error : ?offsets:bool -> [`Byte | `Point] -> - Error.t Region.reg -> file:bool -> unit + error Region.reg -> file:bool -> unit end (* The functorised interface @@ -330,22 +331,23 @@ module Make (Token: TOKEN) : (S with module Token = Token) = (* ERRORS *) - type Error.t += Invalid_utf8_sequence - type Error.t += Unexpected_character of char - type Error.t += Undefined_escape_sequence - type Error.t += Missing_break - type Error.t += Unterminated_string - type Error.t += Unterminated_integer - type Error.t += Odd_lengthed_bytes - type Error.t += Unterminated_comment - type Error.t += Orphan_minus - type Error.t += Non_canonical_zero - type Error.t += Negative_byte_sequence - type Error.t += Broken_string - type Error.t += Invalid_character_in_string - type Error.t += Reserved_name - type Error.t += Invalid_symbol - type Error.t += Invalid_natural + type error = + Invalid_utf8_sequence + | Unexpected_character of char + | Undefined_escape_sequence + | Missing_break + | Unterminated_string + | Unterminated_integer + | Odd_lengthed_bytes + | Unterminated_comment + | Orphan_minus + | Non_canonical_zero + | Negative_byte_sequence + | Broken_string + | Invalid_character_in_string + | Reserved_name + | Invalid_symbol + | Invalid_natural let error_to_string = function Invalid_utf8_sequence -> @@ -393,9 +395,8 @@ module Make (Token: TOKEN) : (S with module Token = Token) = Hint: Check the LIGO syntax you use.\n" | Invalid_natural -> "Invalid natural." - | _ -> assert false - exception Error of Error.t Region.reg + exception Error of error Region.reg let print_error ?(offsets=true) mode Region.{region; value} ~file = let msg = error_to_string value in diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 3d763b1df..2dafdbd17 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -7,20 +7,15 @@ simple-utils uutf getopt - zarith - ) + zarith) (modules - Error Lexer LexerLog Utils Markup FQueue EvalOpt - Version - ) - (modules_without_implementation Error) -) + Version)) (rule (targets Version.ml) From 8210a4e1863d9a1e61683e2e6d96331054a03200 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Tue, 17 Dec 2019 17:03:43 +0100 Subject: [PATCH 07/32] Added basic support for Menhir's incremental API. I added the token Bytes to ReasonLIGO's [LexToken.mll] for the build. --- src/passes/1-parser/cameligo/.Parser.mly.tag | 2 +- src/passes/1-parser/cameligo/ParserAPI.ml | 57 +++++++++++++++++++ src/passes/1-parser/cameligo/ParserAPI.mli | 39 +++++++++++++ src/passes/1-parser/cameligo/ParserMain.ml | 11 ++-- src/passes/1-parser/cameligo/dune | 29 ++++------ src/passes/1-parser/pascaligo/.Parser.mly.tag | 2 +- src/passes/1-parser/pascaligo/ParserAPI.ml | 57 +++++++++++++++++++ src/passes/1-parser/pascaligo/ParserAPI.mli | 39 +++++++++++++ src/passes/1-parser/pascaligo/ParserMain.ml | 11 ++-- src/passes/1-parser/pascaligo/dune | 18 +++--- .../1-parser/reasonligo/.Parser.mly.tag | 2 +- src/passes/1-parser/reasonligo/ParToken.mly | 13 +++-- src/passes/1-parser/reasonligo/ParserAPI.ml | 57 +++++++++++++++++++ src/passes/1-parser/reasonligo/ParserAPI.mli | 39 +++++++++++++ src/passes/1-parser/reasonligo/ParserMain.ml | 11 ++-- src/passes/1-parser/reasonligo/dune | 29 ++++------ 16 files changed, 350 insertions(+), 66 deletions(-) create mode 100644 src/passes/1-parser/cameligo/ParserAPI.ml create mode 100644 src/passes/1-parser/cameligo/ParserAPI.mli create mode 100644 src/passes/1-parser/pascaligo/ParserAPI.ml create mode 100644 src/passes/1-parser/pascaligo/ParserAPI.mli create mode 100644 src/passes/1-parser/reasonligo/ParserAPI.ml create mode 100644 src/passes/1-parser/reasonligo/ParserAPI.mli diff --git a/src/passes/1-parser/cameligo/.Parser.mly.tag b/src/passes/1-parser/cameligo/.Parser.mly.tag index 100f7bb69..37b0cae8c 100644 --- a/src/passes/1-parser/cameligo/.Parser.mly.tag +++ b/src/passes/1-parser/cameligo/.Parser.mly.tag @@ -1 +1 @@ ---explain --external-tokens LexToken --base Parser ParToken.mly +--table --strict --explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/passes/1-parser/cameligo/ParserAPI.ml b/src/passes/1-parser/cameligo/ParserAPI.ml new file mode 100644 index 000000000..7ae5c5ad4 --- /dev/null +++ b/src/passes/1-parser/cameligo/ParserAPI.ml @@ -0,0 +1,57 @@ +(** Generic parser for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) = + struct + + module I = Parser.MenhirInterpreter + + (* The parser has successfully produced a semantic value. *) + + let success v = v + + (* The parser has suspended itself because of a syntax error. Stop. *) + + let fail _checkpoint = raise Parser.Error + + (* The generic parsing function *) + + let incr_contract Lexer.{read; buffer; close; _} : AST.t = + let supplier = I.lexer_lexbuf_to_supplier read buffer in + let parser = Parser.Incremental.contract buffer.Lexing.lex_curr_p in + let ast = I.loop_handle success fail supplier parser + in close (); ast + + let mono_contract = Parser.contract + + end diff --git a/src/passes/1-parser/cameligo/ParserAPI.mli b/src/passes/1-parser/cameligo/ParserAPI.mli new file mode 100644 index 000000000..ff3fe4854 --- /dev/null +++ b/src/passes/1-parser/cameligo/ParserAPI.mli @@ -0,0 +1,39 @@ +(** Generic parser API for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) : + sig + val mono_contract : (Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> AST.t + val incr_contract : Lexer.instance -> AST.t + end diff --git a/src/passes/1-parser/cameligo/ParserMain.ml b/src/passes/1-parser/cameligo/ParserMain.ml index e1e35850b..faa7ce70a 100644 --- a/src/passes/1-parser/cameligo/ParserMain.ml +++ b/src/passes/1-parser/cameligo/ParserMain.ml @@ -76,11 +76,11 @@ let () = (** {1 Instanciating the lexer} *) module Lexer = Lexer.Make (LexToken) - module Log = LexerLog.Make (Lexer) +module ParserFront = ParserAPI.Make (Lexer) (Parser) -let Lexer.{read; buffer; get_pos; get_last; close} = - Lexer.open_token_stream (Some pp_input) +let lexer_inst = Lexer.open_token_stream (Some pp_input) +let Lexer.{read; buffer; get_pos; get_last; close} = lexer_inst and cout = stdout @@ -97,7 +97,10 @@ let tokeniser = read ~log let () = try - let ast = Parser.contract tokeniser buffer in + (* The incremental API *) + let ast = ParserFront.incr_contract lexer_inst in + (* The monolithic API *) + (* let ast = ParserFront.mono_contract tokeniser buffer in *) if Utils.String.Set.mem "ast" options#verbose then let buffer = Buffer.create 131 in let state = ParserLog.mk_state diff --git a/src/passes/1-parser/cameligo/dune b/src/passes/1-parser/cameligo/dune index 31e31a857..ed667617a 100644 --- a/src/passes/1-parser/cameligo/dune +++ b/src/passes/1-parser/cameligo/dune @@ -3,38 +3,33 @@ (menhir (merge_into Parser) (modules ParToken Parser) - (flags -la 1 --explain --external-tokens LexToken)) + (flags -la 1 --table --strict --explain --external-tokens LexToken)) (library (name parser_cameligo) (public_name ligo.parser.cameligo) (modules AST cameligo Parser ParserLog LexToken) (libraries + menhirLib parser_shared str simple-utils tezos-utils - getopt - ) - (flags (:standard -open Simple_utils -open Parser_shared )) -) + getopt) + (flags (:standard -open Simple_utils -open Parser_shared ))) (executable (name LexerMain) - (libraries + (libraries parser_cameligo) - (modules - LexerMain - ) - (flags (:standard -open Parser_shared -open Parser_cameligo)) -) + (modules + LexerMain) + (flags (:standard -open Parser_shared -open Parser_cameligo))) (executable (name ParserMain) - (libraries + (libraries parser_cameligo) - (modules - ParserMain - ) - (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo)) -) + (modules + ParserMain) + (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo))) diff --git a/src/passes/1-parser/pascaligo/.Parser.mly.tag b/src/passes/1-parser/pascaligo/.Parser.mly.tag index ab6790b0f..37b0cae8c 100644 --- a/src/passes/1-parser/pascaligo/.Parser.mly.tag +++ b/src/passes/1-parser/pascaligo/.Parser.mly.tag @@ -1 +1 @@ ---table --explain --external-tokens LexToken --base Parser ParToken.mly +--table --strict --explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/passes/1-parser/pascaligo/ParserAPI.ml b/src/passes/1-parser/pascaligo/ParserAPI.ml new file mode 100644 index 000000000..7ae5c5ad4 --- /dev/null +++ b/src/passes/1-parser/pascaligo/ParserAPI.ml @@ -0,0 +1,57 @@ +(** Generic parser for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) = + struct + + module I = Parser.MenhirInterpreter + + (* The parser has successfully produced a semantic value. *) + + let success v = v + + (* The parser has suspended itself because of a syntax error. Stop. *) + + let fail _checkpoint = raise Parser.Error + + (* The generic parsing function *) + + let incr_contract Lexer.{read; buffer; close; _} : AST.t = + let supplier = I.lexer_lexbuf_to_supplier read buffer in + let parser = Parser.Incremental.contract buffer.Lexing.lex_curr_p in + let ast = I.loop_handle success fail supplier parser + in close (); ast + + let mono_contract = Parser.contract + + end diff --git a/src/passes/1-parser/pascaligo/ParserAPI.mli b/src/passes/1-parser/pascaligo/ParserAPI.mli new file mode 100644 index 000000000..ff3fe4854 --- /dev/null +++ b/src/passes/1-parser/pascaligo/ParserAPI.mli @@ -0,0 +1,39 @@ +(** Generic parser API for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) : + sig + val mono_contract : (Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> AST.t + val incr_contract : Lexer.instance -> AST.t + end diff --git a/src/passes/1-parser/pascaligo/ParserMain.ml b/src/passes/1-parser/pascaligo/ParserMain.ml index 295d460d8..8e64c56eb 100644 --- a/src/passes/1-parser/pascaligo/ParserMain.ml +++ b/src/passes/1-parser/pascaligo/ParserMain.ml @@ -76,11 +76,11 @@ let () = (** {1 Instanciating the lexer} *) module Lexer = Lexer.Make (LexToken) - module Log = LexerLog.Make (Lexer) +module ParserFront = ParserAPI.Make (Lexer) (Parser) -let Lexer.{read; buffer; get_pos; get_last; close} = - Lexer.open_token_stream (Some pp_input) +let lexer_inst = Lexer.open_token_stream (Some pp_input) +let Lexer.{read; buffer; get_pos; get_last; close} = lexer_inst and cout = stdout @@ -97,7 +97,10 @@ let tokeniser = read ~log let () = try - let ast = Parser.contract tokeniser buffer in + (* The incremental API *) + let ast = ParserFront.incr_contract lexer_inst in + (* The monolithic API *) + (* let ast = ParserFront.mono_contract tokeniser buffer in *) if Utils.String.Set.mem "ast" options#verbose then let buffer = Buffer.create 131 in let state = ParserLog.mk_state diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index 03d27a37c..ab405f17b 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -3,18 +3,18 @@ (menhir (merge_into Parser) (modules ParToken Parser) - (flags -la 1 --explain --external-tokens LexToken)) + (flags -la 1 --table --strict --explain --external-tokens LexToken)) (library (name parser_pascaligo) (public_name ligo.parser.pascaligo) (modules AST pascaligo Parser ParserLog LexToken) (libraries + menhirLib parser_shared hex simple-utils - tezos-utils - ) + tezos-utils) (flags (:standard -open Parser_shared -open Simple_utils)) ) @@ -26,20 +26,16 @@ tezos-utils parser_pascaligo) (modules - LexerMain - ) - (flags (:standard -open Parser_shared -open Parser_pascaligo)) -) + LexerMain) + (flags (:standard -open Parser_shared -open Parser_pascaligo))) (executable (name ParserMain) (libraries parser_pascaligo) (modules - ParserMain - ) - (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo)) -) + ParserMain) + (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo))) ;; Les deux directives (rule) qui suivent sont pour le dev local. ;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier. diff --git a/src/passes/1-parser/reasonligo/.Parser.mly.tag b/src/passes/1-parser/reasonligo/.Parser.mly.tag index 100f7bb69..ab6790b0f 100644 --- a/src/passes/1-parser/reasonligo/.Parser.mly.tag +++ b/src/passes/1-parser/reasonligo/.Parser.mly.tag @@ -1 +1 @@ ---explain --external-tokens LexToken --base Parser ParToken.mly +--table --explain --external-tokens LexToken --base Parser ParToken.mly diff --git a/src/passes/1-parser/reasonligo/ParToken.mly b/src/passes/1-parser/reasonligo/ParToken.mly index 561f95265..4a94ddb6b 100644 --- a/src/passes/1-parser/reasonligo/ParToken.mly +++ b/src/passes/1-parser/reasonligo/ParToken.mly @@ -5,12 +5,13 @@ (* Literals *) -%token Ident "" -%token Constr "" -%token String "" -%token <(string * Z.t) Region.reg> Int "" -%token <(string * Z.t) Region.reg> Nat "" -%token <(string * Z.t) Region.reg> Mutez "" +%token String "" +%token <(LexToken.lexeme * Hex.t) Region.reg> Bytes "" +%token <(string * Z.t) Region.reg> Int "" +%token <(string * Z.t) Region.reg> Nat "" +%token <(string * Z.t) Region.reg> Mutez "" +%token Ident "" +%token Constr "" (* Symbols *) diff --git a/src/passes/1-parser/reasonligo/ParserAPI.ml b/src/passes/1-parser/reasonligo/ParserAPI.ml new file mode 100644 index 000000000..7ae5c5ad4 --- /dev/null +++ b/src/passes/1-parser/reasonligo/ParserAPI.ml @@ -0,0 +1,57 @@ +(** Generic parser for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) = + struct + + module I = Parser.MenhirInterpreter + + (* The parser has successfully produced a semantic value. *) + + let success v = v + + (* The parser has suspended itself because of a syntax error. Stop. *) + + let fail _checkpoint = raise Parser.Error + + (* The generic parsing function *) + + let incr_contract Lexer.{read; buffer; close; _} : AST.t = + let supplier = I.lexer_lexbuf_to_supplier read buffer in + let parser = Parser.Incremental.contract buffer.Lexing.lex_curr_p in + let ast = I.loop_handle success fail supplier parser + in close (); ast + + let mono_contract = Parser.contract + + end diff --git a/src/passes/1-parser/reasonligo/ParserAPI.mli b/src/passes/1-parser/reasonligo/ParserAPI.mli new file mode 100644 index 000000000..ff3fe4854 --- /dev/null +++ b/src/passes/1-parser/reasonligo/ParserAPI.mli @@ -0,0 +1,39 @@ +(** Generic parser API for LIGO *) + +module type PARSER = + sig + (* The type of tokens *) + + type token + + (* This exception is raised by the monolithic API functions *) + + exception Error + + (* The monolithic API *) + + val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> AST.t + + (* The incremental API *) + + module MenhirInterpreter : + sig + include MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE + with type token = token + end + + module Incremental : + sig + val contract : Lexing.position -> AST.t MenhirInterpreter.checkpoint + end + + end + +(* Main functor *) + +module Make (Lexer: Lexer.S) + (Parser: PARSER with type token = Lexer.Token.token) : + sig + val mono_contract : (Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> AST.t + val incr_contract : Lexer.instance -> AST.t + end diff --git a/src/passes/1-parser/reasonligo/ParserMain.ml b/src/passes/1-parser/reasonligo/ParserMain.ml index f4e8058cd..f855beb52 100644 --- a/src/passes/1-parser/reasonligo/ParserMain.ml +++ b/src/passes/1-parser/reasonligo/ParserMain.ml @@ -76,11 +76,11 @@ let () = (** {1 Instanciating the lexer} *) module Lexer = Lexer.Make (LexToken) - module Log = LexerLog.Make (Lexer) +module ParserFront = ParserAPI.Make (Lexer) (Parser) -let Lexer.{read; buffer; get_pos; get_last; close} = - Lexer.open_token_stream (Some pp_input) +let lexer_inst = Lexer.open_token_stream (Some pp_input) +let Lexer.{read; buffer; get_pos; get_last; close} = lexer_inst and cout = stdout @@ -97,7 +97,10 @@ let tokeniser = read ~log let () = try - let ast = Parser.contract tokeniser buffer in + (* The incremental API *) + let ast = ParserFront.incr_contract lexer_inst in + (* The monolithic API *) + (* let ast = ParserFront.mono_contract tokeniser buffer in *) if Utils.String.Set.mem "ast" options#verbose then let buffer = Buffer.create 131 in let state = ParserLog.mk_state diff --git a/src/passes/1-parser/reasonligo/dune b/src/passes/1-parser/reasonligo/dune index 6d9da9551..fefe8c10e 100644 --- a/src/passes/1-parser/reasonligo/dune +++ b/src/passes/1-parser/reasonligo/dune @@ -3,39 +3,34 @@ (menhir (merge_into Parser) (modules ParToken Parser) - (flags -la 1 --explain --dump --strict --external-tokens LexToken)) + (flags -la 1 --table --explain --strict --external-tokens LexToken)) (library (name parser_reasonligo) (public_name ligo.parser.reasonligo) (modules reasonligo LexToken Parser) (libraries + menhirLib parser_shared parser_cameligo str simple-utils tezos-utils - getopt - ) - (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo )) -) + getopt) + (flags (:standard -open Simple_utils -open Parser_shared -open Parser_cameligo))) (executable (name LexerMain) - (libraries + (libraries parser_reasonligo) - (modules - LexerMain - ) - (flags (:standard -open Parser_shared -open Parser_reasonligo)) -) + (modules + LexerMain) + (flags (:standard -open Parser_shared -open Parser_reasonligo))) (executable (name ParserMain) - (libraries + (libraries parser_reasonligo) - (modules - ParserMain - ) - (flags (:standard -open Simple_utils -open Parser_shared -open Parser_reasonligo)) -) + (modules + ParserMain) + (flags (:standard -open Simple_utils -open Parser_shared -open Parser_reasonligo))) From 310dde6dc95a9629c721b4619632129edcea3d1f Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 17 Dec 2019 21:04:53 +0000 Subject: [PATCH 08/32] [LIGO-286] Tuple destructuring doesn't do left hand type inference in CameLIGO --- src/passes/2-simplify/cameligo.ml | 8 ++++---- src/test/contracts/type_tuple_destruct.mligo | 11 +++++++++++ src/test/integration_tests.ml | 7 +++++++ 3 files changed, 22 insertions(+), 4 deletions(-) create mode 100644 src/test/contracts/type_tuple_destruct.mligo diff --git a/src/passes/2-simplify/cameligo.ml b/src/passes/2-simplify/cameligo.ml index 054d7272c..530b46042 100644 --- a/src/passes/2-simplify/cameligo.ml +++ b/src/passes/2-simplify/cameligo.ml @@ -564,11 +564,11 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap list result let%bind (v, v_type) = pattern_to_typed_var par_var in let%bind v_type_expression = match v_type with - | Some v_type -> ok @@ (simpl_type_expression v_type) - | None -> fail @@ wrong_pattern "typed var tuple" par_var in - let%bind v_type_expression = v_type_expression in + | Some v_type -> ok (to_option (simpl_type_expression v_type)) + | None -> ok None + in let%bind simpl_rhs_expr = simpl_expression rhs_expr in - ok @@ loc x @@ Declaration_constant (Var.of_name v.value, Some v_type_expression, simpl_rhs_expr) ) + ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, simpl_rhs_expr) ) in let%bind variables = ok @@ npseq_to_list pt.value in let%bind expr_bind_lst = match let_rhs with diff --git a/src/test/contracts/type_tuple_destruct.mligo b/src/test/contracts/type_tuple_destruct.mligo new file mode 100644 index 000000000..05bcaea59 --- /dev/null +++ b/src/test/contracts/type_tuple_destruct.mligo @@ -0,0 +1,11 @@ +type foobar = int * int +let test_t: foobar = 10, 25 +let foo, bar = test_t + +let type_tuple_d (p: unit) = foo + bar + +type complex = string * int * string * nat +let test_t_2 = "hello", 10, "world", 50n +let hello, ten, world, fifty_n = test_t_2 + +let type_tuple_d_2 (p: unit) = hello ^ world diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 14cc41e23..35ffc05e0 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -1765,6 +1765,12 @@ let key_hash () : unit result = let%bind () = expect_eq program "check_hash_key" make_input make_expected in ok () +let type_tuple_destruct () : unit result = + let%bind program = mtype_file "./contracts/type_tuple_destruct.mligo" in + let%bind () = expect_eq program "type_tuple_d" (e_unit ()) (e_int 35) in + let%bind () = expect_eq program "type_tuple_d_2" (e_unit ()) (e_string "helloworld") in + ok () + let main = test_suite "Integration (End to End)" [ test "key hash" key_hash ; test "chain id" chain_id ; @@ -1899,4 +1905,5 @@ let main = test_suite "Integration (End to End)" [ test "simple_access (ligo)" simple_access_ligo; test "deep_access (ligo)" deep_access_ligo; test "entrypoints (ligo)" entrypoints_ligo ; + test "type tuple destruct (mligo)" type_tuple_destruct ; ] From 97a6d7162f9bc400e8baeea208f59fd0cad9d6e4 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Wed, 18 Dec 2019 15:50:42 +0100 Subject: [PATCH 09/32] Regression. --- src/passes/1-parser/shared/dune | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index a59199862..6756867ed 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -16,8 +16,7 @@ FQueue EvalOpt Version - SyntaxError) - (modules_without_implementation Error)) + SyntaxError)) (rule From ea343760b2bd6c87f714e5023aa821b7443d31af Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 16 Dec 2019 11:29:49 +0100 Subject: [PATCH 10/32] compile_parameter and compile_storage CLI commands now gets their input checked --- src/bin/cli.ml | 12 ++---------- src/main/compile/of_mini_c.ml | 14 ++++++++++++++ .../proto-alpha-utils/x_memory_proto_alpha.ml | 4 ++++ 3 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 6ab46b7f6..5540d8ea1 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -150,11 +150,6 @@ let measure_contract = let compile_parameter = let f source_file entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ - (* - TODO: - source_to_michelson_contract will fail if the entry_point does not point to a michelson contract - but we do not check that the type of the parameter matches the type of the given expression - *) let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -169,6 +164,7 @@ let compile_parameter = let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in + let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_parameter michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in @@ -210,11 +206,6 @@ let interpret = let compile_storage = let f source_file entry_point expression syntax display_format michelson_format = toplevel ~display_format @@ - (* - TODO: - source_to_michelson_contract will fail if the entry_point does not point to a michelson contract - but we do not check that the type of the storage matches the type of the given expression - *) let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in @@ -229,6 +220,7 @@ let compile_storage = let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.compile_expression mini_c_param in + let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_storage michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 0ed53895f..32572ae13 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -47,3 +47,17 @@ let build_contract : Compiler.compiled_expression -> Michelson.michelson result Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@ Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in ok contract + +type check_type = Check_parameter | Check_storage +let assert_equal_michelson_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result = + fun c compiled_prg compiled_param -> + let%bind (Ex_ty expected_ty) = + let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in + match c with + | Check_parameter -> ok c_param_ty + | Check_storage -> ok c_storage_ty in + let (Ex_ty actual_ty) = compiled_param.expr_ty in + let%bind _ = + Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@ + Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in + ok () \ No newline at end of file diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 99887c721..460494379 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -1105,6 +1105,10 @@ let typecheck_contract contract = Script_ir_translator.typecheck_code dummy_environment.tezos_context contract' >>=?? fun _ -> return () +let assert_equal_michelson_type ty1 ty2 = + (* alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> *) + alpha_wrap (Script_ir_translator.ty_eq dummy_environment.tezos_context ty1 ty2) + type 'a interpret_res = | Succeed of 'a stack | Fail of Script_repr.expr From f9fcf1fbc3f81b30aa782e99fdc80363841326b5 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 18 Dec 2019 16:34:29 +0100 Subject: [PATCH 11/32] Also perform Ast_typed check --- src/bin/cli.ml | 16 ++++++++------- src/main/compile/of_michelson.ml | 32 +++++++++++++++++++++++++++++ src/main/compile/of_mini_c.ml | 30 --------------------------- src/main/compile/of_typed.ml | 18 +++++++++++++++- src/stages/ast_typed/combinators.ml | 2 +- src/test/coase_tests.ml | 2 +- src/test/multisig_tests.ml | 2 +- src/test/multisig_v2_tests.ml | 2 +- src/test/replaceable_id_tests.ml | 2 +- 9 files changed, 63 insertions(+), 43 deletions(-) create mode 100644 src/main/compile/of_michelson.ml diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 5540d8ea1..b0a2c9251 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -121,7 +121,7 @@ let compile_file = let%bind typed,_ = Compile.Of_simplified.compile simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in - let%bind contract = Compile.Of_mini_c.build_contract michelson in + let%bind contract = Compile.Of_michelson.build_contract michelson in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) contract in let term = @@ -137,7 +137,7 @@ let measure_contract = let%bind typed,_ = Compile.Of_simplified.compile simplified in let%bind mini_c = Compile.Of_typed.compile typed in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_contract mini_c entry_point in - let%bind contract = Compile.Of_mini_c.build_contract michelson in + let%bind contract = Compile.Of_michelson.build_contract michelson in let open Tezos_utils in ok @@ Format.asprintf "%d bytes\n" (Michelson.measure contract) in @@ -157,14 +157,15 @@ let compile_parameter = let env = Ast_typed.program_environment typed_prg in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Compile.Of_mini_c.build_contract michelson_prg in + Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_param in - let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_parameter michelson_prg compiled_param in + let%bind () = Compile.Of_typed.assert_equal_contract_type Check_parameter entry_point typed_prg typed_param in + let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_parameter michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in @@ -213,14 +214,15 @@ let compile_storage = let env = Ast_typed.program_environment typed_prg in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Compile.Of_mini_c.build_contract michelson_prg in + Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind simplified_param = Compile.Of_source.compile_expression v_syntax expression in let%bind (typed_param,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_param in let%bind mini_c_param = Compile.Of_typed.compile_expression typed_param in let%bind compiled_param = Compile.Of_mini_c.compile_expression mini_c_param in - let%bind () = Compile.Of_mini_c.assert_equal_michelson_type Check_storage michelson_prg compiled_param in + let%bind () = Compile.Of_typed.assert_equal_contract_type Check_storage entry_point typed_prg typed_param in + let%bind () = Compile.Of_michelson.assert_equal_contract_type Check_storage michelson_prg compiled_param in let%bind value = Run.evaluate_expression compiled_param.expr compiled_param.expr_ty in ok @@ Format.asprintf "%a\n" (Main.Display.michelson_pp michelson_format) value in @@ -240,7 +242,7 @@ let dry_run = let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Compile.Of_mini_c.build_contract michelson_prg in + Compile.Of_michelson.build_contract michelson_prg in let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind simplified = Compile.Of_source.compile_contract_input storage input v_syntax in diff --git a/src/main/compile/of_michelson.ml b/src/main/compile/of_michelson.ml new file mode 100644 index 000000000..5e73d07c2 --- /dev/null +++ b/src/main/compile/of_michelson.ml @@ -0,0 +1,32 @@ +open Tezos_utils +open Proto_alpha_utils +open Trace + +let build_contract : Compiler.compiled_expression -> Michelson.michelson result = + fun compiled -> + let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in + let%bind param_michelson = + Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse parameter") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in + let%bind storage_michelson = + Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse storage") @@ + Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in + let contract = Michelson.contract param_michelson storage_michelson compiled.expr in + let%bind () = + Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@ + Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in + ok contract + +type check_type = Check_parameter | Check_storage +let assert_equal_contract_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result = + fun c compiled_prg compiled_param -> + let%bind (Ex_ty expected_ty) = + let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in + match c with + | Check_parameter -> ok c_param_ty + | Check_storage -> ok c_storage_ty in + let (Ex_ty actual_ty) = compiled_param.expr_ty in + let%bind _ = + Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@ + Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in + ok () \ No newline at end of file diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 32572ae13..4387ca133 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -1,5 +1,4 @@ open Mini_c -open Tezos_utils open Proto_alpha_utils open Trace @@ -32,32 +31,3 @@ let aggregate_and_compile_contract = fun program name -> let aggregate_and_compile_expression = fun program exp -> aggregate_and_compile program (ExpressionForm exp) - -let build_contract : Compiler.compiled_expression -> Michelson.michelson result = - fun compiled -> - let%bind ((Ex_ty _param_ty),(Ex_ty _storage_ty)) = Self_michelson.fetch_contract_inputs compiled.expr_ty in - let%bind param_michelson = - Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse parameter") @@ - Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _param_ty in - let%bind storage_michelson = - Trace.trace_tzresult_lwt (simple_error "Invalid contract: Could not unparse storage") @@ - Proto_alpha_utils.Memory_proto_alpha.unparse_ty_michelson _storage_ty in - let contract = Michelson.contract param_michelson storage_michelson compiled.expr in - let%bind () = - Trace.trace_tzresult_lwt (simple_error "Invalid contract: Contract did not typecheck") @@ - Proto_alpha_utils.Memory_proto_alpha.typecheck_contract contract in - ok contract - -type check_type = Check_parameter | Check_storage -let assert_equal_michelson_type : check_type -> Compiler.compiled_expression -> Compiler.compiled_expression -> unit result = - fun c compiled_prg compiled_param -> - let%bind (Ex_ty expected_ty) = - let%bind (c_param_ty,c_storage_ty) = Self_michelson.fetch_contract_inputs compiled_prg.expr_ty in - match c with - | Check_parameter -> ok c_param_ty - | Check_storage -> ok c_storage_ty in - let (Ex_ty actual_ty) = compiled_param.expr_ty in - let%bind _ = - Trace.trace_tzresult (simple_error "Passed parameter does not match the contract type") @@ - Proto_alpha_utils.Memory_proto_alpha.assert_equal_michelson_type expected_ty actual_ty in - ok () \ No newline at end of file diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 2fccdd920..0aa705405 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -5,4 +5,20 @@ let compile : Ast_typed.program -> Mini_c.program result = fun p -> Transpiler.transpile_program p let compile_expression : annotated_expression -> Mini_c.expression result = fun e -> - Transpiler.transpile_annotated_expression e \ No newline at end of file + Transpiler.transpile_annotated_expression e + +type check_type = Check_parameter | Check_storage +let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> Ast_typed.value -> unit result = + fun c entry contract param -> Trace.trace (simple_info "Check argument type against contract type") ( + let%bind entry_point = Ast_typed.get_entry contract entry in + match entry_point.type_annotation.type_value' with + | T_arrow (args,_) -> ( + match args.type_value' with + | T_tuple [param_exp;storage_exp] -> ( + match c with + | Check_parameter -> assert_type_value_eq (param_exp, param.type_annotation) + | Check_storage -> assert_type_value_eq (storage_exp, param.type_annotation) + ) + | _ -> dummy_fail + ) + | _ -> dummy_fail ) \ No newline at end of file diff --git a/src/stages/ast_typed/combinators.ml b/src/stages/ast_typed/combinators.ml index 20706a586..c46e39e21 100644 --- a/src/stages/ast_typed/combinators.ml +++ b/src/stages/ast_typed/combinators.ml @@ -138,7 +138,7 @@ let get_t_pair (t:type_value) : (type_value * type_value) result = match t.type_ let get_t_function (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_arrow (a,r) -> ok (a,r) - | _ -> simple_fail "not a tuple" + | _ -> simple_fail "not a function" let get_t_sum (t:type_value) : type_value constructor_map result = match t.type_value' with | T_sum m -> ok m diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index f2196190d..af091ad88 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -26,7 +26,7 @@ let compile_main () = let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Ligo.Compile.Of_mini_c.build_contract michelson_prg in + Ligo.Compile.Of_michelson.build_contract michelson_prg in ok () open Ast_simplified diff --git a/src/test/multisig_tests.ml b/src/test/multisig_tests.ml index 80a17b3d4..d89719c4c 100644 --- a/src/test/multisig_tests.ml +++ b/src/test/multisig_tests.ml @@ -23,7 +23,7 @@ let compile_main () = let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Ligo.Compile.Of_mini_c.build_contract michelson_prg in + Ligo.Compile.Of_michelson.build_contract michelson_prg in ok () open Ast_simplified diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 81d0ca395..e42fd62fe 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -23,7 +23,7 @@ let compile_main () = let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Ligo.Compile.Of_mini_c.build_contract michelson_prg in + Ligo.Compile.Of_michelson.build_contract michelson_prg in ok () open Ast_simplified diff --git a/src/test/replaceable_id_tests.ml b/src/test/replaceable_id_tests.ml index ca04640c1..6bf09e95a 100644 --- a/src/test/replaceable_id_tests.ml +++ b/src/test/replaceable_id_tests.ml @@ -23,7 +23,7 @@ let compile_main () = let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) - Ligo.Compile.Of_mini_c.build_contract michelson_prg in + Ligo.Compile.Of_michelson.build_contract michelson_prg in ok () open Ast_simplified From be84244d7a95dc20d3a97cbab4c4ec2952fe2a71 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 18 Dec 2019 16:35:17 +0100 Subject: [PATCH 12/32] add some CLI tests --- src/bin/expect_tests/contract_tests.ml | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 1facce834..fc87bc8cb 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -16,6 +16,18 @@ let%expect_test _ = run_ligo_good [ "measure-contract" ; contract "vote.mligo" ; "main" ] ; [%expect {| 628 bytes |}] ; + run_ligo_good [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; + [%expect {| (Left (Left 1)) |}] ; + + run_ligo_good [ "compile-storage" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; + [%expect {| (Pair (Pair {} {}) 3) |}] ; + + run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; + [%expect {| ligo: different kinds: {"a":"record[next_id -> nat , cards -> (TO_Map (nat,record[card_pattern -> nat , card_owner -> address])) , card_patterns -> (TO_Map (nat,record[quantity -> nat , coefficient -> mutez]))]","b":"sum[Transfer_single -> record[destination -> address , card_to_transfer -> nat] , Sell_single -> record[card_to_sell -> nat] , Buy_single -> record[card_to_buy -> nat]]"} |}] ; + + run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; + [%expect {| ligo: different kinds: {"a":"sum[Transfer_single -> record[destination -> address , card_to_transfer -> nat] , Sell_single -> record[card_to_sell -> nat] , Buy_single -> record[card_to_buy -> nat]]","b":"record[next_id -> nat , cards -> (TO_Map (nat,record[card_pattern -> nat , card_owner -> address])) , card_patterns -> (TO_Map (nat,record[quantity -> nat , coefficient -> mutez]))]"} |}] ; + () let%expect_test _ = From 172038cef05df392fa974066df07a052a5c721d1 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 10 Dec 2019 12:00:21 -0600 Subject: [PATCH 13/32] Kill warning 45 by reusing Pervasives.result for Trace --- src/main/display.ml | 2 +- src/passes/2-simplify/pascaligo.ml | 2 +- src/passes/6-transpiler/transpiler.ml | 2 +- src/passes/6-transpiler/transpiler.mli | 2 +- src/passes/7-self_mini_c/self_mini_c.ml | 2 +- src/passes/8-compiler/compiler_program.ml | 6 ++-- src/test/test_helpers.ml | 4 +-- vendors/ligo-utils/proto-alpha-utils/trace.ml | 8 +++--- vendors/ligo-utils/simple-utils/trace.ml | 28 +++++++++++-------- 9 files changed, 30 insertions(+), 26 deletions(-) diff --git a/src/main/display.ml b/src/main/display.ml index da22fa883..991f7c2cc 100644 --- a/src/main/display.ml +++ b/src/main/display.ml @@ -1,4 +1,4 @@ -open! Trace +open Trace let rec error_pp ?(dev = false) out (e : error) = let open JSON_string_utils in diff --git a/src/passes/2-simplify/pascaligo.ml b/src/passes/2-simplify/pascaligo.ml index ae96ddc27..6aea532e0 100644 --- a/src/passes/2-simplify/pascaligo.ml +++ b/src/passes/2-simplify/pascaligo.ml @@ -1,4 +1,4 @@ -open! Trace +open Trace open Ast_simplified module Raw = Parser.Pascaligo.AST diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index dd967680e..916c7c88d 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -2,7 +2,7 @@ For more info, see back-end.md: https://gitlab.com/ligolang/ligo/blob/dev/gitlab-pages/docs/contributors/big-picture/back-end.md *) -open! Trace +open Trace open Helpers module AST = Ast_typed diff --git a/src/passes/6-transpiler/transpiler.mli b/src/passes/6-transpiler/transpiler.mli index bebd4aa94..5defe6eba 100644 --- a/src/passes/6-transpiler/transpiler.mli +++ b/src/passes/6-transpiler/transpiler.mli @@ -1,4 +1,4 @@ -open! Trace +open Trace module AST = Ast_typed module Append_tree = Tree.Append diff --git a/src/passes/7-self_mini_c/self_mini_c.ml b/src/passes/7-self_mini_c/self_mini_c.ml index cda2591a1..e025eed42 100644 --- a/src/passes/7-self_mini_c/self_mini_c.ml +++ b/src/passes/7-self_mini_c/self_mini_c.ml @@ -1,5 +1,5 @@ open Mini_c -open! Trace +open Trace (* TODO hack to specialize map_expression to identity monad *) let map_expression : diff --git a/src/passes/8-compiler/compiler_program.ml b/src/passes/8-compiler/compiler_program.ml index 1c370b50a..37c44b7f3 100644 --- a/src/passes/8-compiler/compiler_program.ml +++ b/src/passes/8-compiler/compiler_program.ml @@ -29,8 +29,8 @@ open Errors (* This does not makes sense to me *) let get_operator : constant -> type_value -> expression list -> predicate result = fun s ty lst -> match Operators.Compiler.get_operators s with - | Trace.Ok (x,_) -> ok x - | Trace.Error _ -> ( + | Ok (x,_) -> ok x + | Error _ -> ( match s with | C_NONE -> ( let%bind ty' = Mini_c.get_t_option ty in @@ -452,4 +452,4 @@ and translate_function anon env input_ty output_ty : michelson result = type compiled_expression = { expr_ty : ex_ty ; expr : michelson ; -} \ No newline at end of file +} diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index 5c3e6d771..928e828e8 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -1,4 +1,4 @@ -open! Trace +open Trace type test_case = unit Alcotest.test_case type test = @@ -17,7 +17,7 @@ let wrap_test name f = let wrap_test_raw f = match f () with - | Trace.Ok ((), annotations) -> ignore annotations; () + | Ok ((), annotations) -> ignore annotations; () | Error err -> Format.printf "%a\n%!" (Ligo.Display.error_pp ~dev:true) (err ()) diff --git a/vendors/ligo-utils/proto-alpha-utils/trace.ml b/vendors/ligo-utils/proto-alpha-utils/trace.ml index 812ce0405..54bf77db3 100644 --- a/vendors/ligo-utils/proto-alpha-utils/trace.ml +++ b/vendors/ligo-utils/proto-alpha-utils/trace.ml @@ -11,7 +11,7 @@ let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = function - | Result.Ok x -> ok x + | Ok x -> ok x | Error errs -> fail @@ thunk @@ patch_children (List.map of_alpha_tz_error errs) (err ()) let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = @@ -19,17 +19,17 @@ let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ resul let trace_tzresult err = function - | Result.Ok x -> ok x + | Ok x -> ok x | Error errs -> fail @@ thunk @@ patch_children (List.map of_tz_error errs) (err ()) (* TODO: should be a combination of trace_tzresult and trace_r *) let trace_tzresult_r err_thunk_may_fail = function - | Result.Ok x -> ok x + | Ok x -> ok x | Error errs -> let tz_errs = List.map of_tz_error errs in match err_thunk_may_fail () with - | Simple_utils.Trace.Ok (err, annotations) -> + | Ok (err, annotations) -> ignore annotations ; Error (fun () -> patch_children tz_errs (err ())) | Error errors_while_generating_error -> diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 7464d8fb1..dc80894d4 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -6,8 +6,8 @@ *) module Trace_tutorial = struct - (** The trace monad is fairly similar to the predefined option - type. *) + (** The trace monad is fairly similar to the predefined [option] + type. It is an instance of the predefined [result] type. *) type annotation = string type error = string @@ -23,18 +23,20 @@ module Trace_tutorial = struct 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]. + second by [Error]. *) - type 'a result = - Ok of 'a * annotation list - | Errors of error list + type nonrec 'a result = ('a * annotation list, error list) result + (* + = Ok of 'a * annotation list + | Error of error list + *) (** 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] + then Error [Printf.sprintf "division by zero: %d/%d" a b] else Ok (a/b, []) (** The function [divide_three] shows that when composing two @@ -81,7 +83,7 @@ module Trace_tutorial = struct match f x with Ok (x', annot') -> Ok (x', annot' @ annot) | errors -> ignore annot; errors) - | Errors _ as e -> e + | Error _ as e -> e (** The function [divide_three_bind] is equivalent to the verbose [divide_three] above, but makes use of [bind]. @@ -169,7 +171,7 @@ module Trace_tutorial = struct {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 + is [Error], then [bind_list] returns the first error in the list.}} *) let rec bind_list = function @@ -199,7 +201,7 @@ module Trace_tutorial = struct And this will pass along the error triggered by [get key map]. *) let trace err = function - Errors e -> Errors (err::e) + Error e -> Error (err::e) | ok -> ok (** The real trace monad is very similar to the one that we have @@ -293,9 +295,11 @@ type annotation_thunk = annotation thunk (** Types of traced elements. It might be good to rename it [trace] at some point. *) -type 'a result = - Ok of 'a * annotation_thunk list +type nonrec 'a result = ('a * annotation_thunk list, error_thunk) result +(* += Ok of 'a * annotation_thunk list | Error of error_thunk +*) (** {1 Constructors} *) From d47ec7cf7c1288f294ddd2ac029de4aa4448ae57 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Wed, 18 Dec 2019 16:53:32 +0100 Subject: [PATCH 14/32] Fixed a tag file (local build of PascaLIGO with my Makefile). --- src/passes/1-parser/pascaligo/.Parser.mly.tag | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/passes/1-parser/pascaligo/.Parser.mly.tag b/src/passes/1-parser/pascaligo/.Parser.mly.tag index 9f81cf45b..37b0cae8c 100644 --- a/src/passes/1-parser/pascaligo/.Parser.mly.tag +++ b/src/passes/1-parser/pascaligo/.Parser.mly.tag @@ -1 +1 @@ ---table --strict --explain --external-tokens LexToken --base Parser \ No newline at end of file +--table --strict --explain --external-tokens LexToken --base Parser ParToken.mly From 9512992d2ba37db263f81ce27e8236285e2c7bf4 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Wed, 18 Dec 2019 21:21:39 +0100 Subject: [PATCH 15/32] Generating .msg files and extracting from them LIGO source files. --- vendors/ligo-utils/simple-utils/cover.sh | 258 ++++++++++++++++++++ vendors/ligo-utils/simple-utils/messages.sh | 222 +++++++++++++++++ 2 files changed, 480 insertions(+) create mode 100755 vendors/ligo-utils/simple-utils/cover.sh create mode 100755 vendors/ligo-utils/simple-utils/messages.sh diff --git a/vendors/ligo-utils/simple-utils/cover.sh b/vendors/ligo-utils/simple-utils/cover.sh new file mode 100755 index 000000000..e4717b5ca --- /dev/null +++ b/vendors/ligo-utils/simple-utils/cover.sh @@ -0,0 +1,258 @@ +#!/bin/sh + +# This script extracts the error states of an LR automaton produced by +# Menhir and generates minimal inputs that cover all of them and only +# them. + +set -x + +# ==================================================================== +# General Settings and wrappers + +script=$(basename $0) + +print_nl () { test "$quiet" != "yes" && echo "$1"; } + +print () { test "$quiet" != "yes" && printf "$1"; } + +fatal_error () { + echo "$script: fatal error:" + echo "$1" 1>&2 + exit 1 +} + +warn () { + print_nl "$script: warning:" + print_nl "$1" +} + +failed () { + printf "\033[31mFAILED$1\033[0m\n" +} + +emphasise () { + printf "\033[31m$1\033[0m\n" +} + +# ==================================================================== +# Parsing loop +# +while : ; do + case "$1" in + "") break;; + --par-tokens=*) + if test -n "$par_tokens"; then + fatal_error "Repeated option --par-tokens."; fi + par_tokens=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --par-tokens) + no_eq=$1 + break + ;; + --lex-tokens=*) + if test -n "$lex_tokens"; then + fatal_error "Repeated option --lex-tokens."; fi + lex_tokens=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --lex-tokens) + no_eq=$1 + break + ;; + --ext=*) + if test -n "$ext_opt"; then + fatal_error "Repeated option --ext."; fi + ext=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --ext) + no_eq=$1 + break + ;; + --dir=*) + if test -n "$dir_opt"; then + fatal_error "Repeated option --dir."; fi + dir=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --dir) + no_eq=$1 + break + ;; + # Help + # + --unlexer=*) + if test -n "$unlexer"; then + fatal_error "Repeated option --unlexer."; fi + unlexer=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --unlexer) + no_eq=$1 + break + ;; + -h | --help | -help) + help=yes + ;; + # Invalid option + # + -*) + fatal_error "Invalid option \"$1\"." + ;; + # Invalid argument + # + *) + if test -n "$parser_arg"; then + fatal_error "Only one Menhir specification allowed."; fi + parser=$1 + esac + shift +done + +# ==================================================================== +# Help +# +usage () { + cat <.mly + --lex-tokens=.mli + --unlexer= + --ext= + --dir= + .mly + +Generates in directory a set of LIGO source files with +extension covering all erroneous states of the LR +automaton produced by Menhir from .mly, .mly, +.mli and .msg (see script `messages.sh` for +generating the latter). The LIGO files will be numbered with their +corresponding state number in the automaton. The executable +reads a line on stdin of tokens and produces a line of corresponding +lexemes. + +The following options, if given, must be given only once. + +Display control: + -h, --help display this help and exit + +Mandatory options: + --lex-tokens=.mli the lexical tokens + --par-tokens=.mly the syntactical tokens + --ext=EXT Unix file extension for the + generated LIGO files + (no starting period) + --dir=PATH directory to store the generated + LIGO files (no trailing slash) + --unlexer= from tokens to lexemes (one line on stdin) +EOF + exit 1 +} + +if test "$help" = "yes"; then usage; fi + +# ==================================================================== +# Checking the command-line options and arguments and applying some of +# them. + +# It is a common mistake to forget the "=" in GNU long-option style. + +if test -n "$no_eq" +then + fatal_error "Long option style $no_eq must be followed by \"=\"." +fi + +# Checking options + +if test -z "$unlexer"; then + fatal_error "Unlexer binary not found (use --unlexer)."; fi + +if test -z "$parser"; then + fatal_error "No parser specification."; fi + +if test -z "$par_tokens"; then + fatal_error "No syntactical tokens specification (use --par-tokens)."; fi + +if test -z "$lex_tokens"; then + fatal_error "No lexical tokens specification (use --lex-tokens)."; fi + +if test ! -e "$parser"; then + fatal_error "Parser specification \"$parser\" not found."; fi + +if test ! -e "$lex_tokens"; then + fatal_error "Lexical tokens specification \"$lex_tokens\" not found."; fi + +if test ! -e "$par_tokens"; then + fatal_error "Syntactical tokens specification \"$par_tokens\" not found."; fi + +parser_ext=$(expr "$parser" : ".*\.mly$") +if test "$parser_ext" = "0"; then + fatal_error "Parser specification must have extension \".mly\"."; fi + +par_tokens_ext=$(expr "$par_tokens" : ".*\.mly$") +if test "$par_tokens_ext" = "0"; then + fatal_error "Syntactical tokens specification must have extension \".mly\"." +fi + +lex_tokens_ext=$(expr "$lex_tokens" : ".*\.mli$") +if test "$lex_tokens_ext" = "0"; then + fatal_error "Lexical tokens specification must have extension \".mli\"." +fi + +mly=$parser +parser_base=$(basename $mly .mly) +par_tokens_base=$(basename $par_tokens .mly) +lex_tokens_base=$(basename $lex_tokens .mli) + +# Checking the output directory + +if test -z "$dir"; then + fatal_error "No output directory (use --dir)."; fi + +if test ! -d "$dir"; then + fatal_error "Output directory \"$dir\" not found."; fi + +# Checking the LIGO extension + +if test -z "$ext"; then + fatal_error "No LIGO extension (use --ext)."; fi + +ext_start=$(expr "$ext" : "^\..*") +if test "$ext_start" != "0" +then fatal_error "LIGO extensions must not start with a period." +fi + +# Checking the presence of the messages + +msg=$parser_base.msg +if test ! -e $msg; then + fatal_error "File $msg not found."; fi + +# ==================================================================== +# Menhir's flags + +flags="--table --strict --external-tokens $lex_tokens_base \ + --base $parser_base $par_tokens" + +# ==================================================================== +# Producing erroneous sentences from Menhir's error messages + +msg=$parser_base.msg +raw=$parser_base.msg.raw +printf "Making $raw from $msg... " +menhir --echo-errors $parser_base.msg $flags $mly > $raw 2>/dev/null +sed -i -e 's/^.*: \(.*\)$/\1/g' $raw +printf "done.\n" + +# ==================================================================== +# Converting Menhir's minimal erroneous sentences to concrete syntax + +printf "Unlexing the erroneous sentences... " +states=$msg.states +map=$msg.map +sed -n "s/.* state\: \([0-9]\+\)./\1/p" $msg > $states +paste -d ':' $states $raw > $map +rm -f $dir/*.$ext +while read -r line; do + state=$(echo $line | sed -n 's/\(.*\):.*/\1/p') + filename=$(printf "$dir/%04d.$ext" $state) + sentence=$(echo $line | sed -n 's/.*:\(.*\)/\1/p') + echo $sentence | $unlexer >> $filename +done < $map +printf "done.\n" diff --git a/vendors/ligo-utils/simple-utils/messages.sh b/vendors/ligo-utils/simple-utils/messages.sh new file mode 100755 index 000000000..c9e0034e7 --- /dev/null +++ b/vendors/ligo-utils/simple-utils/messages.sh @@ -0,0 +1,222 @@ +#!/bin/sh + +# This script uses Menhir to generate the exhaustive list of errors +# for a given parser specification. The generated file has to be +# filled with the error messages. The script must be called in the +# same directory where the parser specification and external token +# specifications are located, in accordance with the convention of the +# LIGO compiler source code. + +#set -x + +# ==================================================================== +# General Settings and wrappers + +script=$(basename $0) + +print_nl () { test "$quiet" != "yes" && echo "$1"; } + +print () { test "$quiet" != "yes" && printf "$1"; } + +fatal_error () { + echo "$script: fatal error:" + echo "$1" 1>&2 + exit 1 +} + +warn () { + print_nl "$script: warning:" + print_nl "$1" +} + +failed () { + printf "\033[31mFAILED$1\033[0m\n" +} + +emphasise () { + printf "\033[31m$1\033[0m\n" +} + +# ==================================================================== +# Parsing loop +# +while : ; do + case "$1" in + "") break;; + --par-tokens=*) + if test -n "$par_tokens"; then + fatal_error "Repeated option --par-tokens."; fi + par_tokens=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --par-tokens) + no_eq=$1 + break + ;; + --lex-tokens=*) + if test -n "$lex_tokens"; then + fatal_error "Repeated option --lex-tokens."; fi + lex_tokens=$(expr "$1" : "[^=]*=\(.*\)") + ;; + --lex-tokens) + no_eq=$1 + break + ;; + -h | --help | -help) + help=yes + ;; + # Invalid option + # + -*) + fatal_error "Invalid option \"$1\"." + ;; + # Invalid argument + # + *) + if test -n "$parser"; then + fatal_error "Only one Menhir specification allowed."; fi + parser=$1 + esac + shift +done + +# ==================================================================== +# Help +# +usage () { + cat <.mli \ +--par-tokens=.mly .mly + +Generates in place .msg, the form containing the exhaustive +list of errors for the LR automaton generated by Menhir from +.mly, .mly and .mli. The file +.msg is meant to be edited and filled with the error messages. + +The following options, if given, must be given only once. + +Display control: + -h, --help display this help and exit +Mandatory options: + --lex-tokens=.mli the lexical tokens + --par-tokens=.mly the syntactical tokens +EOF + exit 1 +} + +if test "$help" = "yes"; then usage; fi + +# ==================================================================== +# Checking the command-line options and arguments and applying some of +# them. + +# It is a common mistake to forget the "=" in GNU long-option style. + +if test -n "$no_eq"; then + fatal_error "Long option style $no_eq must be followed by \"=\"." +fi + +# Checking the parser and tokens + +if test -z "$parser"; then + fatal_error "No parser specification."; fi + +if test -z "$par_tokens"; then + fatal_error "No syntactical tokens specification (use --par-tokens)."; fi + +if test -z "$lex_tokens"; then + fatal_error "No lexical tokens specification (use --lex-tokens)."; fi + +if test ! -e "$parser"; then + fatal_error "Parser specification \"$parser\" not found."; fi + +if test ! -e "$lex_tokens"; then + fatal_error "Lexical tokens specification \"$lex_tokens\" not found."; fi + +if test ! -e "$par_tokens"; then + fatal_error "Syntactical tokens specification \"$par_tokens\" not found."; fi + +parser_ext=$(expr "$parser" : ".*\.mly$") +if test "$parser_ext" = "0"; then + fatal_error "Parser specification must have extension \".mly\"."; fi + +par_tokens_ext=$(expr "$par_tokens" : ".*\.mly$") +if test "$par_tokens_ext" = "0"; then + fatal_error "Syntactical tokens specification must have extension \".mly\"." +fi + +lex_tokens_ext=$(expr "$lex_tokens" : ".*\.mli$") +if test "$lex_tokens_ext" = "0"; then + fatal_error "Lexical tokens specification must have extension \".mli\"." +fi + +mly=$parser +parser_base=$(basename $mly .mly) +par_tokens_base=$(basename $par_tokens .mly) +lex_tokens_base=$(basename $lex_tokens .mli) + +# ==================================================================== +# Menhir's flags + +flags="--table --strict --external-tokens $lex_tokens_base \ + --base $parser_base $par_tokens" + +# ==================================================================== +# Generating error messages with Menhir + +msg=$parser_base.msg +err=.$msg.err +out=.$mly.out + +if test -e $msg; then mv -f $msg $msg.old; echo "Saved $msg."; fi + +printf "Making new $msg from $mly... " +menhir --list-errors $flags $mly > $msg 2>$out + +if test "$?" = "0"; then + sentences=$(grep "YOUR SYNTAX ERROR MESSAGE HERE" $msg | wc -l) + if test -z "$sentences"; then printf "done.\n" + else + spurious=$(grep WARNING $msg | wc -l) + printf "done:\n" + printf "There are %s error sentences, %s with spurious reductions.\n" \ + $sentences $spurious; fi + if test -s $out; then cat $out; fi + if test -f $msg.old; then + printf "Checking inclusion of mappings (new in old)... " + menhir --compare-errors $msg \ + --compare-errors $msg.old \ + $flags $mly 2> $out + if test "$?" = "0"; then + if test -s $out; then + printf "done:\n" + cat $out + else printf "done.\n"; fi + rm -f $out + printf "Updating $msg... " + menhir --update-errors $msg.old \ + $flags $mly > $msg 2> $err + if test "$?" = "0"; then + printf "done:\n" + emphasise "Warning: The LR items may have changed." + emphasise "> Check your error messages again." + rm -f $err + else failed "." + touch $err + mv -f $msg.old $msg + echo "Restored $msg."; fi + else failed ":" + mv -f $out $err + sed -i -e "s/\.msg/.msg.new/g" \ + -e "s/\.new\.old//g" $err + mv -f $msg $msg.new + emphasise "See $err and update $msg." + echo "The default messages are in $msg.new." + mv -f $msg.old $msg + echo "Restored $msg."; fi; fi +else + failed ":" + mv -f $out $err + emphasise "> See $err." + mv -f $msg.old $msg + echo "Restored $msg." +fi From 3add77eba55bfec5d9d0edc5bf8378d08a861f21 Mon Sep 17 00:00:00 2001 From: Christian Rinderknecht Date: Wed, 18 Dec 2019 21:32:12 +0100 Subject: [PATCH 16/32] Adding the build of the unlexer by dune. --- src/passes/1-parser/pascaligo/dune | 32 ++++++++++++++++-------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/src/passes/1-parser/pascaligo/dune b/src/passes/1-parser/pascaligo/dune index ab405f17b..53c2d8385 100644 --- a/src/passes/1-parser/pascaligo/dune +++ b/src/passes/1-parser/pascaligo/dune @@ -10,33 +10,35 @@ (public_name ligo.parser.pascaligo) (modules AST pascaligo Parser ParserLog LexToken) (libraries - menhirLib - parser_shared - hex - simple-utils - tezos-utils) - (flags (:standard -open Parser_shared -open Simple_utils)) -) + menhirLib + parser_shared + hex + simple-utils + tezos-utils) + (flags (:standard -open Parser_shared -open Simple_utils))) (executable (name LexerMain) (libraries - hex - simple-utils - tezos-utils - parser_pascaligo) + hex + simple-utils + tezos-utils + parser_pascaligo) (modules - LexerMain) + LexerMain) (flags (:standard -open Parser_shared -open Parser_pascaligo))) (executable (name ParserMain) (libraries - parser_pascaligo) - (modules - ParserMain) + parser_pascaligo) + (modules ParserMain) (flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo))) +(executable + (name Unlexer) + (modules Unlexer)) + ;; Les deux directives (rule) qui suivent sont pour le dev local. ;; Il suffit de faire "dune build Parser.exe" pour avoir un Parser.exe dans le dossier. ;; Pour le purger, il faut faire "dune clean". From 600ae2d4f624098f5cc53c37fa49be2d682b842b Mon Sep 17 00:00:00 2001 From: Sander Date: Thu, 19 Dec 2019 13:50:57 +0000 Subject: [PATCH 17/32] Move to Trace.error instead of simple_error. --- src/passes/1-parser/reasonligo.ml | 167 ++++++++---------- src/passes/1-parser/reasonligo/Parser.mly | 4 +- .../{shared => reasonligo}/SyntaxError.ml | 2 +- .../{shared => reasonligo}/SyntaxError.mli | 2 +- src/passes/1-parser/reasonligo/dune | 2 +- src/passes/1-parser/reasonligo/reasonligo.ml | 1 + src/passes/1-parser/shared/dune | 4 +- 7 files changed, 79 insertions(+), 103 deletions(-) rename src/passes/1-parser/{shared => reasonligo}/SyntaxError.ml (50%) rename src/passes/1-parser/{shared => reasonligo}/SyntaxError.mli (50%) diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index a3b52b110..260ddae3d 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/src/passes/1-parser/reasonligo.ml @@ -5,6 +5,73 @@ module AST = Parser_cameligo.AST module ParserLog = Parser_cameligo.ParserLog module LexToken = Parser_reasonligo.LexToken module Lexer = Lexer.Make(LexToken) +module SyntaxError = Parser_reasonligo.SyntaxError + +module Errors = struct + + let wrong_function_arguments expr = + let title () = "wrong function arguments" in + let message () = "" in + let expression_loc = AST.expr_to_region expr in + let data = [ + ("expression_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc) + ] in + error ~data title message + + let parser_error start end_ = + let title () = "parser error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("parser_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + + let unrecognized_error start end_ = + let title () = "unrecognized error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("unrecognized_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + +end + +open Errors + +type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a + +let parse (parser: 'a parser) lexbuf = + let Lexer.{read ; close ; _} = Lexer.open_token_stream None in + let result = + try + ok (parser read lexbuf) + with + | SyntaxError.Error (WrongFunctionArguments e) -> + fail @@ (wrong_function_arguments e) + | Parser.Error -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (parser_error start end_) + | _ -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (unrecognized_error start end_) + in + close (); + result let parse_file (source: string) : AST.t result = let pp_input = @@ -20,104 +87,12 @@ let parse_file (source: string) : AST.t result = generic_try (simple_error "error opening file") @@ (fun () -> open_in pp_input) in let lexbuf = Lexing.from_channel channel in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | SyntaxError.Error WrongFunctionArguments -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Incorrect function arguments at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_string (s:string) : AST.t result = let lexbuf = Lexing.from_string s in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - let Lexer.{read ; close; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname s - in - simple_error str - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + let lexbuf = Lexing.from_string s in + parse (Parser.interactive_expr) lexbuf diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 444d12212..23deaf776 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -424,7 +424,7 @@ fun_expr: {p.value with inside = arg_to_pattern p.value.inside} in PPar {p with value} | EUnit u -> PUnit u - | _ -> raise (SyntaxError.Error WrongFunctionArguments) + | e -> raise (SyntaxError.Error (WrongFunctionArguments e)) in let fun_args_to_pattern = function EAnnot { @@ -453,7 +453,7 @@ fun_expr: in arg_to_pattern (fst fun_args), bindings | EUnit e -> arg_to_pattern (EUnit e), [] - | _ -> raise (SyntaxError.Error WrongFunctionArguments) + | e -> raise (SyntaxError.Error (WrongFunctionArguments e)) in let binders = fun_args_to_pattern $1 in let f = {kwd_fun; diff --git a/src/passes/1-parser/shared/SyntaxError.ml b/src/passes/1-parser/reasonligo/SyntaxError.ml similarity index 50% rename from src/passes/1-parser/shared/SyntaxError.ml rename to src/passes/1-parser/reasonligo/SyntaxError.ml index a0faa0bbb..befbb27c2 100644 --- a/src/passes/1-parser/shared/SyntaxError.ml +++ b/src/passes/1-parser/reasonligo/SyntaxError.ml @@ -1,4 +1,4 @@ type error = - | WrongFunctionArguments + | WrongFunctionArguments of AST.expr exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/shared/SyntaxError.mli b/src/passes/1-parser/reasonligo/SyntaxError.mli similarity index 50% rename from src/passes/1-parser/shared/SyntaxError.mli rename to src/passes/1-parser/reasonligo/SyntaxError.mli index a0faa0bbb..befbb27c2 100644 --- a/src/passes/1-parser/shared/SyntaxError.mli +++ b/src/passes/1-parser/reasonligo/SyntaxError.mli @@ -1,4 +1,4 @@ type error = - | WrongFunctionArguments + | WrongFunctionArguments of AST.expr exception Error of error \ No newline at end of file diff --git a/src/passes/1-parser/reasonligo/dune b/src/passes/1-parser/reasonligo/dune index fefe8c10e..f26008059 100644 --- a/src/passes/1-parser/reasonligo/dune +++ b/src/passes/1-parser/reasonligo/dune @@ -8,7 +8,7 @@ (library (name parser_reasonligo) (public_name ligo.parser.reasonligo) - (modules reasonligo LexToken Parser) + (modules SyntaxError reasonligo LexToken Parser) (libraries menhirLib parser_shared diff --git a/src/passes/1-parser/reasonligo/reasonligo.ml b/src/passes/1-parser/reasonligo/reasonligo.ml index e2cd732ea..48dd4401b 100644 --- a/src/passes/1-parser/reasonligo/reasonligo.ml +++ b/src/passes/1-parser/reasonligo/reasonligo.ml @@ -3,3 +3,4 @@ module AST = Parser_cameligo.AST module Lexer = Lexer module LexToken = LexToken module ParserLog = Parser_cameligo.ParserLog +module SyntaxError = SyntaxError diff --git a/src/passes/1-parser/shared/dune b/src/passes/1-parser/shared/dune index 6756867ed..61c43fb28 100644 --- a/src/passes/1-parser/shared/dune +++ b/src/passes/1-parser/shared/dune @@ -15,8 +15,8 @@ Markup FQueue EvalOpt - Version - SyntaxError)) + Version + )) (rule From e919a1eba38d1af5192c33cd6e2d9d9f2f5606c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Dec 2019 16:02:21 +0000 Subject: [PATCH 18/32] Fixes unsoundness in old typer (expected type for the expression as a whole was not checked for ascriptions) --- src/bin/expect_tests/typer_error_tests.ml | 4 ++-- src/passes/4-typer-old/typer.ml | 9 ++++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index 5a407316f..75cbe96a3 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -7,5 +7,5 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_2.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(TO_list(string))","b":"(TO_option(int))"} |} ] ; - (* run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ; - * [%expect …some type error… ] ; *) + run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ; + [%expect {| ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"tuple[int , string , bool]","b":"tuple[int , string]"} |} ] ; diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 7792edcdb..7093f1d24 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -464,8 +464,6 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. | None -> ok () | Some tv' -> O.assert_type_value_eq (tv' , ae.type_annotation) in ok(ae) - - (* Sum *) | E_constructor (c, expr) -> let%bind (c_tv, sum_tv) = @@ -793,7 +791,12 @@ and type_expression' : environment -> ?tv_opt:O.type_value -> I.expression -> O. (Some tv) (Some expr'.type_annotation) (internal_assertion_failure "merge_annotations (Some ...) (Some ...) failed") in - ok {expr' with type_annotation} + (* check type annotation of the expression as a whole (e.g. let x : t = (v : t') ) *) + let%bind () = + match tv_opt with + | None -> ok () + | Some tv' -> O.assert_type_value_eq (tv' , type_annotation) in + ok @@ {expr' with type_annotation} and type_constant (name:I.constant) (lst:O.type_value list) (tv_opt:O.type_value option) : (O.constant * O.type_value) result = From 2a11c6d180c3b241396e4ff0f2ae6dd34d978b88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Dec 2019 18:16:25 +0000 Subject: [PATCH 19/32] test for typer error message: different keys --- src/bin/expect_tests/typer_error_tests.ml | 4 ++++ src/test/contracts/error_typer_4.mligo | 7 +++++++ 2 files changed, 11 insertions(+) create mode 100644 src/test/contracts/error_typer_4.mligo diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index 75cbe96a3..6c1dc3cb1 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -9,3 +9,7 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"tuple[int , string , bool]","b":"tuple[int , string]"} |} ] ; + + run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_4.mligo" ; "foo" ] ; + [%expect {| ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record: {"key_a":"d","key_b":"c"} |} ] ; + diff --git a/src/test/contracts/error_typer_4.mligo b/src/test/contracts/error_typer_4.mligo new file mode 100644 index 000000000..a09820a8b --- /dev/null +++ b/src/test/contracts/error_typer_4.mligo @@ -0,0 +1,7 @@ +type toto = { a : int ; b : string ; c : bool } +type tata = { a : int ; d : string ; c : bool } + +let foo : tata = ({a = 1 ; b = "foo" ; c = true} : toto) + +let main (p:int) (storage : int) = + (([] : operation list) , p + foo.a) From a835bc9286f99b67449eceb00e65c508be0de981 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Dec 2019 22:46:36 +0000 Subject: [PATCH 20/32] Added "did you mean" feature for unbound type names --- src/passes/4-typer-old/typer.ml | 8 +++++++- src/test/contracts/error_typer_5.mligo | 4 ++++ 2 files changed, 11 insertions(+), 1 deletion(-) create mode 100644 src/test/contracts/error_typer_5.mligo diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 7093f1d24..b2cc7824e 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -12,13 +12,19 @@ type environment = Environment.t module Errors = struct let unbound_type_variable (e:environment) (tv:I.type_variable) () = + let name = Var.to_name tv in + let suggestion = match name with + | "integer" -> "int" + | "str" -> "string" + | _ -> "no suggestion" in let title = (thunk "unbound type variable") in let message () = "" in let data = [ ("variable" , fun () -> Format.asprintf "%a" Stage_common.PP.type_variable tv) ; (* TODO: types don't have srclocs for now. *) (* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *) - ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) + ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ; + ("did_you_mean" , fun () -> suggestion) ] in error ~data title message () diff --git a/src/test/contracts/error_typer_5.mligo b/src/test/contracts/error_typer_5.mligo new file mode 100644 index 000000000..ae3391ce5 --- /dev/null +++ b/src/test/contracts/error_typer_5.mligo @@ -0,0 +1,4 @@ +let foo : integer = 3 + +let main (p:int) (storage : int) = + (([] : operation list) , p + foo) From f9daa64aa7fb15c23a9918acb5a0c2a8533ec78d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Dec 2019 22:55:12 +0000 Subject: [PATCH 21/32] Moved negative tests to a negative/ folder --- src/bin/expect_tests/typer_error_tests.ml | 8 ++++---- src/test/contracts/negative/README | 1 + src/test/contracts/{ => negative}/error_typer_1.mligo | 0 src/test/contracts/{ => negative}/error_typer_2.mligo | 0 src/test/contracts/{ => negative}/error_typer_3.mligo | 0 src/test/contracts/{ => negative}/error_typer_4.mligo | 0 src/test/contracts/{ => negative}/error_typer_5.mligo | 0 src/test/dune | 3 ++- 8 files changed, 7 insertions(+), 5 deletions(-) create mode 100644 src/test/contracts/negative/README rename src/test/contracts/{ => negative}/error_typer_1.mligo (100%) rename src/test/contracts/{ => negative}/error_typer_2.mligo (100%) rename src/test/contracts/{ => negative}/error_typer_3.mligo (100%) rename src/test/contracts/{ => negative}/error_typer_4.mligo (100%) rename src/test/contracts/{ => negative}/error_typer_5.mligo (100%) diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index 6c1dc3cb1..7cc8821fd 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -1,15 +1,15 @@ open Cli_expect let%expect_test _ = - run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_1.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_1.mligo", line 3, characters 19-27. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"int"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_2.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(TO_list(string))","b":"(TO_option(int))"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_3.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"tuple[int , string , bool]","b":"tuple[int , string]"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/error_typer_4.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "foo" ] ; [%expect {| ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record: {"key_a":"d","key_b":"c"} |} ] ; diff --git a/src/test/contracts/negative/README b/src/test/contracts/negative/README new file mode 100644 index 000000000..7e17f7aea --- /dev/null +++ b/src/test/contracts/negative/README @@ -0,0 +1 @@ +This folder contains contracts for negative tests: contracts that are expected to fail (parse error, type error and so on). diff --git a/src/test/contracts/error_typer_1.mligo b/src/test/contracts/negative/error_typer_1.mligo similarity index 100% rename from src/test/contracts/error_typer_1.mligo rename to src/test/contracts/negative/error_typer_1.mligo diff --git a/src/test/contracts/error_typer_2.mligo b/src/test/contracts/negative/error_typer_2.mligo similarity index 100% rename from src/test/contracts/error_typer_2.mligo rename to src/test/contracts/negative/error_typer_2.mligo diff --git a/src/test/contracts/error_typer_3.mligo b/src/test/contracts/negative/error_typer_3.mligo similarity index 100% rename from src/test/contracts/error_typer_3.mligo rename to src/test/contracts/negative/error_typer_3.mligo diff --git a/src/test/contracts/error_typer_4.mligo b/src/test/contracts/negative/error_typer_4.mligo similarity index 100% rename from src/test/contracts/error_typer_4.mligo rename to src/test/contracts/negative/error_typer_4.mligo diff --git a/src/test/contracts/error_typer_5.mligo b/src/test/contracts/negative/error_typer_5.mligo similarity index 100% rename from src/test/contracts/error_typer_5.mligo rename to src/test/contracts/negative/error_typer_5.mligo diff --git a/src/test/dune b/src/test/dune index 8d32a8624..24a44109f 100644 --- a/src/test/dune +++ b/src/test/dune @@ -15,7 +15,8 @@ (alias (name ligo-test) (action (run ./test.exe)) - (deps (glob_files contracts/*)) + (deps (glob_files contracts/*) + (glob_files contracts/negative/*)) ) (alias From f7616b7b4916c98769336b06ddf56c9ae2e30b3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 17 Dec 2019 22:59:28 +0000 Subject: [PATCH 22/32] Small improvements to negative typer tests --- src/bin/expect_tests/typer_error_tests.ml | 12 ++++++++---- src/passes/4-typer-old/typer.ml | 1 + src/test/contracts/negative/error_typer_1.mligo | 3 +++ src/test/contracts/negative/error_typer_2.mligo | 3 +++ src/test/contracts/negative/error_typer_5.mligo | 2 +- 5 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index 7cc8821fd..e68d52d14 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -1,15 +1,19 @@ open Cli_expect let%expect_test _ = - run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_1.mligo" ; "main" ] ; [%expect {| ligo: in file "error_typer_1.mligo", line 3, characters 19-27. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"int"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_2.mligo" ; "main" ] ; [%expect {| ligo: in file "error_typer_2.mligo", line 3, characters 24-39. different type constructors: Expected these two n-ary type constructors to be the same, but they're different {"a":"(TO_list(string))","b":"(TO_option(int))"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_3.mligo" ; "main" ] ; [%expect {| ligo: in file "error_typer_3.mligo", line 3, characters 34-53. tuples have different sizes: Expected these two types to be the same, but they're different (both are tuples, but with a different number of arguments) {"a":"tuple[int , string , bool]","b":"tuple[int , string]"} |} ] ; - run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "foo" ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_4.mligo" ; "main" ] ; [%expect {| ligo: in file "error_typer_4.mligo", line 4, characters 17-56. different keys in record: {"key_a":"d","key_b":"c"} |} ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ; + [%expect {| ligo: unbound type variable: {"variable":"boolean","in":"- E[]\tT[] ]","did_you_mean":"bool"} |} ] ; + + diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index b2cc7824e..57918b67f 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -16,6 +16,7 @@ module Errors = struct let suggestion = match name with | "integer" -> "int" | "str" -> "string" + | "boolean" -> "bool" | _ -> "no suggestion" in let title = (thunk "unbound type variable") in let message () = "" in diff --git a/src/test/contracts/negative/error_typer_1.mligo b/src/test/contracts/negative/error_typer_1.mligo index b39f46dd9..5baabe8c9 100644 --- a/src/test/contracts/negative/error_typer_1.mligo +++ b/src/test/contracts/negative/error_typer_1.mligo @@ -1,3 +1,6 @@ type toto = int let foo : string = 42 + 127 + +let main (p:int) (storage : int) = + (([] : operation list) , p + foo) diff --git a/src/test/contracts/negative/error_typer_2.mligo b/src/test/contracts/negative/error_typer_2.mligo index 77534fee2..b8cf9d3cb 100644 --- a/src/test/contracts/negative/error_typer_2.mligo +++ b/src/test/contracts/negative/error_typer_2.mligo @@ -1,3 +1,6 @@ type toto = int option let foo : string list = Some (42 + 127) + +let main (p:int) (storage : int) = + (([] : operation list) , p) diff --git a/src/test/contracts/negative/error_typer_5.mligo b/src/test/contracts/negative/error_typer_5.mligo index ae3391ce5..942438933 100644 --- a/src/test/contracts/negative/error_typer_5.mligo +++ b/src/test/contracts/negative/error_typer_5.mligo @@ -1,4 +1,4 @@ -let foo : integer = 3 +let foo : boolean = 3 let main (p:int) (storage : int) = (([] : operation list) , p + foo) From e5acdc4228dbd28db49fa34a16dc1843d08491c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 19 Dec 2019 17:26:05 +0000 Subject: [PATCH 23/32] All typer errors in ast_typed/misc.ml are covered it seems. --- src/bin/expect_tests/typer_error_tests.ml | 6 ++++++ src/stages/ast_typed/misc.ml | 4 ++-- src/test/contracts/negative/error_typer_6.mligo | 3 +++ src/test/contracts/negative/error_typer_7.mligo | 7 +++++++ 4 files changed, 18 insertions(+), 2 deletions(-) create mode 100644 src/test/contracts/negative/error_typer_6.mligo create mode 100644 src/test/contracts/negative/error_typer_7.mligo diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index e68d52d14..6ecae91e7 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -16,4 +16,10 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_5.mligo" ; "main" ] ; [%expect {| ligo: unbound type variable: {"variable":"boolean","in":"- E[]\tT[] ]","did_you_mean":"bool"} |} ] ; + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_6.mligo" ; "main" ] ; + [%expect {| ligo: in file "error_typer_6.mligo", line 1, characters 30-64. different type constructors: Expected these two constant type constructors to be the same, but they're different {"a":"string","b":"bool"} |} ] ; + + run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/error_typer_7.mligo" ; "main" ] ; + [%expect {| ligo: in file "error_typer_7.mligo", line 4, characters 17-56. records have different sizes: Expected these two types to be the same, but they're different (both are records, but with a different number of arguments) {"a":"record[b -> string , a -> int]","b":"record[c -> bool , b -> string , a -> int]"} |} ] ; + diff --git a/src/stages/ast_typed/misc.ml b/src/stages/ast_typed/misc.ml index 4303a6f1b..ebfd7ee27 100644 --- a/src/stages/ast_typed/misc.ml +++ b/src/stages/ast_typed/misc.ml @@ -56,7 +56,7 @@ module Errors = struct let different_types name a b () = let title () = name ^ " are different" in - let message () = "" in + let message () = "Expected these two types to be the same, but they're different" in let data = [ ("a" , fun () -> Format.asprintf "%a" PP.type_value a) ; ("b" , fun () -> Format.asprintf "%a" PP.type_value b ) @@ -321,7 +321,7 @@ let rec assert_type_value_eq (a, b: (type_value * type_value)) : unit result = m | TC_big_map (ka,va), TC_big_map (kb,vb) -> ok @@ ([ka;va] ,[kb;vb]) | _,_ -> fail @@ different_operators opa opb in - trace (different_types "constant sub-expression" a b) + trace (different_types "arguments to type operators" a b) @@ bind_list_iter (fun (a,b) -> assert_type_value_eq (a,b) )(List.combine lsta lstb) ) | T_operator _, _ -> fail @@ different_kinds a b diff --git a/src/test/contracts/negative/error_typer_6.mligo b/src/test/contracts/negative/error_typer_6.mligo new file mode 100644 index 000000000..d885cd036 --- /dev/null +++ b/src/test/contracts/negative/error_typer_6.mligo @@ -0,0 +1,3 @@ +let foo : (int, string) map = (Map.literal [] : (int, bool) map) +let main (p:int) (storage : int) = + (([] : operation list) , p) diff --git a/src/test/contracts/negative/error_typer_7.mligo b/src/test/contracts/negative/error_typer_7.mligo new file mode 100644 index 000000000..00243b095 --- /dev/null +++ b/src/test/contracts/negative/error_typer_7.mligo @@ -0,0 +1,7 @@ +type toto = { a : int ; b : string } +type tata = { a : int ; } + +let foo : tata = ({a = 1 ; b = "foo" ; c = true} : toto) + +let main (p:int) (storage : int) = + (([] : operation list) , p + foo.a) From 71e267057285774c7a697c06f2b79cce35f3e8fe Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Thu, 19 Dec 2019 13:02:45 -0600 Subject: [PATCH 24/32] Fix one hex printing bug --- src/stages/common/PP.ml | 6 +++++- src/stages/common/dune | 3 ++- src/stages/mini_c/PP.ml | 7 +++++-- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 411681a2a..05d192911 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -188,10 +188,14 @@ let literal ppf (l:literal) = match l with | Literal_timestamp n -> fprintf ppf "+%d" n | Literal_mutez n -> fprintf ppf "%dmutez" n | Literal_string s -> fprintf ppf "%S" s - | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b + | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b) | Literal_address s -> fprintf ppf "@%S" s | Literal_operation _ -> fprintf ppf "Operation(...bytes)" | Literal_key s -> fprintf ppf "key %s" s | Literal_key_hash s -> fprintf ppf "key_hash %s" s | Literal_signature s -> fprintf ppf "Signature %s" s | Literal_chain_id s -> fprintf ppf "Chain_id %s" s + +let%expect_test _ = + Format.printf "%a" literal (Literal_bytes (Bytes.of_string "foo")) ; + [%expect{| 0x666f6f |}] diff --git a/src/stages/common/dune b/src/stages/common/dune index 35a886824..c607b6041 100644 --- a/src/stages/common/dune +++ b/src/stages/common/dune @@ -5,8 +5,9 @@ simple-utils tezos-utils ) + (inline_tests) (preprocess - (pps ppx_let) + (pps ppx_let ppx_expect) ) (flags (:standard -open Simple_utils)) ) diff --git a/src/stages/mini_c/PP.ml b/src/stages/mini_c/PP.ml index 9e6ee6049..054d88cb9 100644 --- a/src/stages/mini_c/PP.ml +++ b/src/stages/mini_c/PP.ml @@ -58,8 +58,7 @@ let rec value ppf : value -> unit = function | D_unit -> fprintf ppf "unit" | D_string s -> fprintf ppf "\"%s\"" s | D_bytes x -> - let (`Hex hex) = Hex.of_bytes x in - fprintf ppf "0x%s" hex + fprintf ppf "0x%a" Hex.pp @@ Hex.of_bytes x | D_pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b | D_left a -> fprintf ppf "L(%a)" value a | D_right b -> fprintf ppf "R(%a)" value b @@ -124,6 +123,10 @@ let tl_statement ppf (ass, _) = assignment ppf ass let program ppf (p:program) = fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p +let%expect_test _ = + Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ; + [%expect{| 0x666f6f |}] + let%expect_test _ = let pp = expression' Format.std_formatter in let dummy_type = T_base Base_unit in From d7bea52d44c1c33bca6308e12502eedd6c700998 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 17 Dec 2019 10:20:39 -0600 Subject: [PATCH 25/32] Unignore dune-project --- .gitignore | 1 - dune-project | 3 +++ vendors/ligo-utils/memory-proto-alpha/dune-project | 2 ++ vendors/ligo-utils/proto-alpha-utils/dune-project | 2 ++ vendors/ligo-utils/simple-utils/dune-project | 2 ++ .../ligo-utils/tezos-protocol-alpha-parameters/dune-project | 2 ++ vendors/ligo-utils/tezos-protocol-alpha/dune-project | 2 ++ vendors/ligo-utils/tezos-utils/dune-project | 2 ++ vendors/ligo-utils/tezos-utils/michelson-parser/dune-project | 2 ++ 9 files changed, 17 insertions(+), 1 deletion(-) create mode 100644 dune-project create mode 100644 vendors/ligo-utils/memory-proto-alpha/dune-project create mode 100644 vendors/ligo-utils/proto-alpha-utils/dune-project create mode 100644 vendors/ligo-utils/simple-utils/dune-project create mode 100644 vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project create mode 100644 vendors/ligo-utils/tezos-protocol-alpha/dune-project create mode 100644 vendors/ligo-utils/tezos-utils/dune-project create mode 100644 vendors/ligo-utils/tezos-utils/michelson-parser/dune-project diff --git a/.gitignore b/.gitignore index cf5ed1f94..5794afd17 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,4 @@ /_build/ -dune-project *~ *.merlin cache/* diff --git a/dune-project b/dune-project new file mode 100644 index 000000000..b3ec15752 --- /dev/null +++ b/dune-project @@ -0,0 +1,3 @@ +(lang dune 1.11) +(name ligo) +(using menhir 2.0) diff --git a/vendors/ligo-utils/memory-proto-alpha/dune-project b/vendors/ligo-utils/memory-proto-alpha/dune-project new file mode 100644 index 000000000..1cf86c9fe --- /dev/null +++ b/vendors/ligo-utils/memory-proto-alpha/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-memory-proto-alpha) diff --git a/vendors/ligo-utils/proto-alpha-utils/dune-project b/vendors/ligo-utils/proto-alpha-utils/dune-project new file mode 100644 index 000000000..45c9397fd --- /dev/null +++ b/vendors/ligo-utils/proto-alpha-utils/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name proto-alpha-utils) diff --git a/vendors/ligo-utils/simple-utils/dune-project b/vendors/ligo-utils/simple-utils/dune-project new file mode 100644 index 000000000..f33d41d33 --- /dev/null +++ b/vendors/ligo-utils/simple-utils/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name simple-utils) diff --git a/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project new file mode 100644 index 000000000..6910ef322 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha-parameters/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-protocol-005-PsBabyM1-parameters) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/dune-project b/vendors/ligo-utils/tezos-protocol-alpha/dune-project new file mode 100644 index 000000000..d4d600dc7 --- /dev/null +++ b/vendors/ligo-utils/tezos-protocol-alpha/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-embedded-protocol-005-PsBabyM1) diff --git a/vendors/ligo-utils/tezos-utils/dune-project b/vendors/ligo-utils/tezos-utils/dune-project new file mode 100644 index 000000000..d08be9590 --- /dev/null +++ b/vendors/ligo-utils/tezos-utils/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name tezos-utils) diff --git a/vendors/ligo-utils/tezos-utils/michelson-parser/dune-project b/vendors/ligo-utils/tezos-utils/michelson-parser/dune-project new file mode 100644 index 000000000..9b32caac7 --- /dev/null +++ b/vendors/ligo-utils/tezos-utils/michelson-parser/dune-project @@ -0,0 +1,2 @@ +(lang dune 1.11) +(name michelson-parser) From 8374d4a31655afa4fbb166d6a0040006a4523734 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Tue, 17 Dec 2019 10:21:27 -0600 Subject: [PATCH 26/32] Ignore ligo.install --- .gitignore | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 5794afd17..fb756e969 100644 --- a/.gitignore +++ b/.gitignore @@ -6,4 +6,5 @@ Version.ml /_opam/ /*.pp.ligo **/.DS_Store -.vscode/ \ No newline at end of file +.vscode/ +/ligo.install From 92523bc4a5bc1f0bcdaa2746a682758fd6781cd7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 19 Dec 2019 16:09:53 +0100 Subject: [PATCH 27/32] exposing context type to be able to modify the timestamps in the tests --- .../tezos-protocol-alpha/alpha_context.mli | 2 +- .../tezos-protocol-alpha/raw_context.mli | 29 ++++++++++++++++++- 2 files changed, 29 insertions(+), 2 deletions(-) diff --git a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli index b970ad110..73dcb59ea 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/alpha_context.mli @@ -30,7 +30,7 @@ module type BASIC_DATA = sig val pp: Format.formatter -> t -> unit end -type t +type t = Raw_context.t type context = t type public_key = Signature.Public_key.t diff --git a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli index 86cc62187..749878b6c 100644 --- a/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli +++ b/vendors/ligo-utils/tezos-protocol-alpha/raw_context.mli @@ -45,7 +45,34 @@ val storage_error: storage_error -> 'a tzresult Lwt.t (** Abstract view of the context. Includes a handle to the functional key-value database ({!Context.t}) along with some in-memory values (gas, etc.). *) -type t +module Int_set : sig + type t +end +type t = { + context: Context.t ; + constants: Constants_repr.parametric ; + first_level: Raw_level_repr.t ; + level: Level_repr.t ; + predecessor_timestamp: Time.t ; + timestamp: Time.t ; + fitness: Int64.t ; + deposits: Tez_repr.t Signature.Public_key_hash.Map.t ; + included_endorsements: int ; + allowed_endorsements: + (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t ; + fees: Tez_repr.t ; + rewards: Tez_repr.t ; + block_gas: Z.t ; + operation_gas: Gas_limit_repr.t ; + internal_gas: Gas_limit_repr.internal_gas ; + storage_space_to_pay: Z.t option ; + allocated_contracts: int option ; + origination_nonce: Contract_repr.origination_nonce option ; + temporary_big_map: Z.t ; + internal_nonce: int ; + internal_nonces_used: Int_set.t ; +} + type context = t type root_context = t From e8c8aa4d2b6a9926bb7fde323bbecadb6b915c0d Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 19 Dec 2019 16:10:09 +0100 Subject: [PATCH 28/32] Time lock : contract + tests --- src/test/contracts/time-lock.ligo | 25 +++++++++++ src/test/test.ml | 1 + src/test/time_lock_tests.ml | 73 +++++++++++++++++++++++++++++++ 3 files changed, 99 insertions(+) create mode 100644 src/test/contracts/time-lock.ligo create mode 100644 src/test/time_lock_tests.ml diff --git a/src/test/contracts/time-lock.ligo b/src/test/contracts/time-lock.ligo new file mode 100644 index 000000000..c45f40a23 --- /dev/null +++ b/src/test/contracts/time-lock.ligo @@ -0,0 +1,25 @@ +type storage_t is timestamp + +type message_t is (unit -> list(operation)) +type default_pt is unit +type call_pt is message_t +type contract_return_t is (list(operation) * storage_t) + +type entry_point_t is +| Call of call_pt +| Default of default_pt + +function call (const p : call_pt; const s : storage_t) : contract_return_t is block { + if s >= now then failwith("Contract is still time locked") else skip ; + const message : message_t = p ; + const ret_ops : list(operation) = message(unit) ; +} with (ret_ops,s) + +function default (const p : default_pt; const s : storage_t) : contract_return_t is + ((nil: list(operation)) , s) + +function main(const param : entry_point_t; const s : storage_t) : contract_return_t is + case param of + | Call (p) -> call(p,s) + | Default (p) -> default(p,s) +end \ No newline at end of file diff --git a/src/test/test.ml b/src/test/test.ml index b1cafc9cf..b63e1ad5f 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -13,5 +13,6 @@ let () = Multisig_tests.main ; Multisig_v2_tests.main ; Replaceable_id_tests.main ; + Time_lock_tests.main ; ] ; () diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml new file mode 100644 index 000000000..9daac3825 --- /dev/null +++ b/src/test/time_lock_tests.ml @@ -0,0 +1,73 @@ +open Trace +open Test_helpers + +let type_file f = + let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in + let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + ok @@ (typed,state) + +let get_program = + let s = ref None in + fun () -> match !s with + | Some s -> ok s + | None -> ( + let%bind program = type_file "./contracts/time-lock.ligo" in + s := Some program ; + ok program + ) + +let compile_main () = + let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/time-lock.ligo" (Syntax_name "pascaligo") in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in + let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in + let%bind (_contract: Tezos_utils.Michelson.michelson) = + (* fails if the given entry point is not a valid contract *) + Ligo.Compile.Of_michelson.build_contract michelson_prg in + ok () + +open Ast_simplified +let empty_op_list = + (e_typed_list [] t_operation) +let empty_message = e_lambda (Var.of_name "arguments") + (Some t_unit) (Some (t_list t_operation)) + empty_op_list + +let call msg = e_constructor "Call" msg +let mk_time st = + match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with + | Some s -> ok s + | None -> simple_fail "bad timestamp notation" +let to_sec t = Tezos_utils.Time.Protocol.to_seconds t +let storage st = e_timestamp (Int64.to_int @@ to_sec st) + +let early_call () = + let%bind program,_ = get_program () in + let%bind now = mk_time "2000-01-01T00:10:10Z" in + let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in + let init_storage = storage lock_time in + let options = + let tezos_context = { Proto_alpha_utils.Memory_proto_alpha.dummy_environment.tezos_context with + predecessor_timestamp = now ; } in + Proto_alpha_utils.Memory_proto_alpha.make_options ~tezos_context () in + let exp_failwith = "Contract is still time locked" in + expect_string_failwith ~options program "main" + (e_pair (call empty_message) init_storage) exp_failwith + +let call_on_time () = + let%bind program,_ = get_program () in + let%bind now = mk_time "2000-01-01T10:10:10Z" in + let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in + let init_storage = storage lock_time in + let options = + let tezos_context = { Proto_alpha_utils.Memory_proto_alpha.dummy_environment.tezos_context with + predecessor_timestamp = now ; } in + Proto_alpha_utils.Memory_proto_alpha.make_options ~tezos_context () in + expect_eq ~options program "main" + (e_pair (call empty_message) init_storage) (e_pair empty_op_list init_storage) + +let main = test_suite "Time lock" [ + test "compile" compile_main ; + test "early call" early_call ; + test "call on time" call_on_time ; + ] \ No newline at end of file From 2086dd9ab51a8752c047299918f5c0e4087e51c1 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 19 Dec 2019 18:59:00 +0100 Subject: [PATCH 29/32] add predecessor timestamp to the CLI --- src/bin/cli.ml | 38 +++++++++++-------- src/main/run/of_michelson.ml | 10 ++++- src/test/time_lock_tests.ml | 12 ++---- .../proto-alpha-utils/x_memory_proto_alpha.ml | 5 ++- 4 files changed, 40 insertions(+), 25 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index b0a2c9251..edc0d9b44 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -66,7 +66,7 @@ let amount = let open Arg in let info = let docv = "AMOUNT" in - let doc = "$(docv) is the amount the dry-run transaction will use." in + let doc = "$(docv) is the amount the michelson interpreter will use." in info ~docv ~doc ["amount"] in value @@ opt string "0" info @@ -74,7 +74,7 @@ let sender = let open Arg in let info = let docv = "SENDER" in - let doc = "$(docv) is the sender the dry-run transaction will use." in + let doc = "$(docv) is the sender the michelson interpreter transaction will use." in info ~docv ~doc ["sender"] in value @@ opt (some string) None info @@ -82,10 +82,18 @@ let source = let open Arg in let info = let docv = "SOURCE" in - let doc = "$(docv) is the source the dry-run transaction will use." in + let doc = "$(docv) is the source the michelson interpreter transaction will use." in info ~docv ~doc ["source"] in value @@ opt (some string) None info +let predecessor_timestamp = + let open Arg in + let info = + let docv = "PREDECESSOR_TIMESTAMP" in + let doc = "$(docv) is the pedecessor_timestamp the michelson interpreter transaction will use (e.g. '2000-01-01T10:10:10Z')" in + info ~docv ~doc ["predecessor-timestamp"] in + value @@ opt (some string) None info + let display_format = let open Arg in let info = @@ -176,7 +184,7 @@ let compile_parameter = (Term.ret term , Term.info ~doc cmdname) let interpret = - let f expression init_file syntax amount sender source display_format = + let f expression init_file syntax amount sender source predecessor_timestamp display_format = toplevel ~display_format @@ let%bind (decl_list,state,env) = match init_file with | Some init_file -> @@ -192,13 +200,13 @@ let interpret = let%bind (typed_exp,_) = Compile.Of_simplified.compile_expression ~env ~state simplified_exp in let%bind mini_c_exp = Compile.Of_typed.compile_expression typed_exp in let%bind compiled_exp = Compile.Of_mini_c.aggregate_and_compile_expression decl_list mini_c_exp in - let%bind options = Run.make_dry_run_options {amount ; sender ; source } in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in let%bind value = Run.run ~options compiled_exp.expr compiled_exp.expr_ty in let%bind simplified_output = Uncompile.uncompile_expression typed_exp.type_annotation value in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = - Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ display_format ) in + Term.(const f $ expression "EXPRESSION" 0 $ init_file $ syntax $ amount $ sender $ source $ predecessor_timestamp $ display_format ) in let cmdname = "interpret" in let doc = "Subcommand: interpret the expression in the context initialized by the provided source file." in (Term.ret term , Term.info ~doc cmdname) @@ -233,7 +241,7 @@ let compile_storage = (Term.ret term , Term.info ~doc cmdname) let dry_run = - let f source_file entry_point storage input amount sender source syntax display_format = + let f source_file entry_point storage input amount sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,state = Compile.Of_simplified.compile simplified in @@ -251,20 +259,20 @@ let dry_run = let%bind compiled_params = Compile.Of_mini_c.compile_expression mini_c in let%bind args_michelson = Run.evaluate_expression compiled_params.expr compiled_params.expr_ty in - let%bind options = Run.make_dry_run_options {amount ; sender ; source } in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in let%bind michelson_output = Run.run_contract ~options michelson_prg.expr michelson_prg.expr_ty args_michelson in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = - Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ syntax $ display_format) in + Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "dry-run" in let doc = "Subcommand: run a smart-contract with the given storage and input." in (Term.ret term , Term.info ~doc cmdname) let run_function = - let f source_file entry_point parameter amount sender source syntax display_format = + let f source_file entry_point parameter amount sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in let%bind simplified_prg = Compile.Of_source.compile source_file (Syntax_name syntax) in @@ -278,32 +286,32 @@ let run_function = let%bind compiled_applied = Compile.Of_typed.compile_expression typed_app in let%bind michelson = Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied in - let%bind options = Run.make_dry_run_options {amount ; sender ; source } in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in let%bind michelson_output = Run.run ~options michelson.expr michelson.expr_ty in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_function_result typed_prg entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = - Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ syntax $ display_format) in + Term.(const f $ source_file 0 $ entry_point 1 $ expression "PARAMETER" 2 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "run-function" in let doc = "Subcommand: run a function with the given parameter." in (Term.ret term , Term.info ~doc cmdname) let evaluate_value = - let f source_file entry_point amount sender source syntax display_format = + let f source_file entry_point amount sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in let%bind typed_prg,_ = Compile.Of_simplified.compile simplified in let%bind mini_c = Compile.Of_typed.compile typed_prg in let%bind (exp,_) = Mini_c.get_entry mini_c entry_point in let%bind compiled = Compile.Of_mini_c.aggregate_and_compile_expression mini_c exp in - let%bind options = Run.make_dry_run_options {amount ; sender ; source } in + let%bind options = Run.make_dry_run_options {predecessor_timestamp ; amount ; sender ; source } in let%bind michelson_output = Run.run ~options compiled.expr compiled.expr_ty in let%bind simplified_output = Uncompile.uncompile_typed_program_entry_expression_result typed_prg entry_point michelson_output in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression simplified_output in let term = - Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ syntax $ display_format) in + Term.(const f $ source_file 0 $ entry_point 1 $ amount $ sender $ source $ predecessor_timestamp $ syntax $ display_format) in let cmdname = "evaluate-value" in let doc = "Subcommand: evaluate a given definition." in (Term.ret term , Term.info ~doc cmdname) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index ae2a2ea9f..ff7f99ff0 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -16,6 +16,7 @@ type run_failwith_res = type dry_run_options = { amount : string ; + predecessor_timestamp : string option ; sender : string option ; source : string option } @@ -44,7 +45,14 @@ let make_dry_run_options (opts : dry_run_options) : options result = (simple_error "invalid source address") (Contract.of_b58check source) in ok (Some source) in - ok @@ make_options ~amount ?source:sender ?payer:source () + let%bind predecessor_timestamp = + match opts.predecessor_timestamp with + | None -> ok None + | Some st -> + match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with + | Some t -> ok (Some t) + | None -> simple_fail "bad timestamp notation" in + ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ?source:sender ?payer:source () let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result = let (Ex_typed_value (value , ty)) = v in diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml index 9daac3825..83830b11f 100644 --- a/src/test/time_lock_tests.ml +++ b/src/test/time_lock_tests.ml @@ -43,26 +43,22 @@ let storage st = e_timestamp (Int64.to_int @@ to_sec st) let early_call () = let%bind program,_ = get_program () in - let%bind now = mk_time "2000-01-01T00:10:10Z" in + let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in let init_storage = storage lock_time in let options = - let tezos_context = { Proto_alpha_utils.Memory_proto_alpha.dummy_environment.tezos_context with - predecessor_timestamp = now ; } in - Proto_alpha_utils.Memory_proto_alpha.make_options ~tezos_context () in + Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in let exp_failwith = "Contract is still time locked" in expect_string_failwith ~options program "main" (e_pair (call empty_message) init_storage) exp_failwith let call_on_time () = let%bind program,_ = get_program () in - let%bind now = mk_time "2000-01-01T10:10:10Z" in + let%bind predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in let init_storage = storage lock_time in let options = - let tezos_context = { Proto_alpha_utils.Memory_proto_alpha.dummy_environment.tezos_context with - predecessor_timestamp = now ; } in - Proto_alpha_utils.Memory_proto_alpha.make_options ~tezos_context () in + Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in expect_eq ~options program "main" (e_pair (call empty_message) init_storage) (e_pair empty_op_list init_storage) diff --git a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml index 460494379..d47b85086 100644 --- a/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml +++ b/vendors/ligo-utils/proto-alpha-utils/x_memory_proto_alpha.ml @@ -1066,13 +1066,16 @@ type options = { let make_options ?(tezos_context = dummy_environment.tezos_context) + ?(predecessor_timestamp = dummy_environment.tezos_context.predecessor_timestamp) ?(source = (List.nth dummy_environment.identities 0).implicit_contract) ?(self = (List.nth dummy_environment.identities 0).implicit_contract) ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) ?(amount = Alpha_context.Tez.one) ?(chain_id = Environment.Chain_id.zero) () - = { + = + let tezos_context = { tezos_context with predecessor_timestamp } in + { tezos_context ; source ; self ; From e18233434de406730c2c1f360bdd850cc1011f1f Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 19 Dec 2019 18:59:27 +0100 Subject: [PATCH 30/32] dune promote --- src/bin/expect_tests/help_tests.ml | 36 ++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index 9c8efcb6a..e804c8283 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -278,7 +278,7 @@ let%expect_test _ = OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the dry-run transaction will use. + AMOUNT is the amount the michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -293,16 +293,22 @@ let%expect_test _ = `pager', `groff' or `plain'. With `auto', the format is `pager` or `plain' whenever the TERM env var is `dumb' or undefined. + --predecessor-timestamp=PREDECESSOR_TIMESTAMP + PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson + interpreter transaction will use (e.g. '2000-01-01T10:10:10Z') + -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported syntaxes are "pascaligo" and "cameligo". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively). --sender=SENDER - SENDER is the sender the dry-run transaction will use. + SENDER is the sender the michelson interpreter transaction will + use. --source=SOURCE - SOURCE is the source the dry-run transaction will use. + SOURCE is the source the michelson interpreter transaction will + use. --version Show version information. |} ] ; @@ -330,7 +336,7 @@ let%expect_test _ = OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the dry-run transaction will use. + AMOUNT is the amount the michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -345,16 +351,22 @@ let%expect_test _ = `pager', `groff' or `plain'. With `auto', the format is `pager` or `plain' whenever the TERM env var is `dumb' or undefined. + --predecessor-timestamp=PREDECESSOR_TIMESTAMP + PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson + interpreter transaction will use (e.g. '2000-01-01T10:10:10Z') + -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported syntaxes are "pascaligo" and "cameligo". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively). --sender=SENDER - SENDER is the sender the dry-run transaction will use. + SENDER is the sender the michelson interpreter transaction will + use. --source=SOURCE - SOURCE is the source the dry-run transaction will use. + SOURCE is the source the michelson interpreter transaction will + use. --version Show version information. |} ] ; @@ -377,7 +389,7 @@ let%expect_test _ = OPTIONS --amount=AMOUNT (absent=0) - AMOUNT is the amount the dry-run transaction will use. + AMOUNT is the amount the michelson interpreter will use. --format=DISPLAY_FORMAT, --display-format=DISPLAY_FORMAT (absent=human-readable) @@ -392,16 +404,22 @@ let%expect_test _ = `pager', `groff' or `plain'. With `auto', the format is `pager` or `plain' whenever the TERM env var is `dumb' or undefined. + --predecessor-timestamp=PREDECESSOR_TIMESTAMP + PREDECESSOR_TIMESTAMP is the pedecessor_timestamp the michelson + interpreter transaction will use (e.g. '2000-01-01T10:10:10Z') + -s SYNTAX, --syntax=SYNTAX (absent=auto) SYNTAX is the syntax that will be used. Currently supported syntaxes are "pascaligo" and "cameligo". By default, the syntax is guessed from the extension (.ligo and .mligo, respectively). --sender=SENDER - SENDER is the sender the dry-run transaction will use. + SENDER is the sender the michelson interpreter transaction will + use. --source=SOURCE - SOURCE is the source the dry-run transaction will use. + SOURCE is the source the michelson interpreter transaction will + use. --version Show version information. |} ] ; From 70977d1f00696d10fed67de18863e3b07ac030ac Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 19 Dec 2019 19:12:44 +0100 Subject: [PATCH 31/32] improve badly annotated timestamp error --- src/main/run/of_michelson.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/main/run/of_michelson.ml b/src/main/run/of_michelson.ml index ff7f99ff0..ef26bc11a 100644 --- a/src/main/run/of_michelson.ml +++ b/src/main/run/of_michelson.ml @@ -51,7 +51,7 @@ let make_dry_run_options (opts : dry_run_options) : options result = | Some st -> match Memory_proto_alpha.Protocol.Alpha_context.Timestamp.of_notation st with | Some t -> ok (Some t) - | None -> simple_fail "bad timestamp notation" in + | None -> simple_fail ("\""^st^"\" is a bad timestamp notation") in ok @@ make_options ?predecessor_timestamp:predecessor_timestamp ~amount ?source:sender ?payer:source () let ex_value_ty_to_michelson (v : ex_typed_value) : Michelson.t result = From 638b45611d6e0ffd4b7902222aa1a96400e19f0b Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 20 Dec 2019 12:52:44 +0100 Subject: [PATCH 32/32] fix message of redundant_match_case error --- src/passes/4-typer-new/typer.ml | 2 +- src/passes/4-typer-old/typer.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/passes/4-typer-new/typer.ml b/src/passes/4-typer-new/typer.ml index 865461c58..f22dd61f9 100644 --- a/src/passes/4-typer-new/typer.ml +++ b/src/passes/4-typer-new/typer.ml @@ -54,7 +54,7 @@ module Errors = struct let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ = fun matching loc () -> - let title = (thunk "missing case in match") in + let title = (thunk "redundant case in match") in let message () = "" in let data = [ ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ; diff --git a/src/passes/4-typer-old/typer.ml b/src/passes/4-typer-old/typer.ml index 57918b67f..b54b7e579 100644 --- a/src/passes/4-typer-old/typer.ml +++ b/src/passes/4-typer-old/typer.ml @@ -61,7 +61,7 @@ module Errors = struct let match_redundant_case : type a . (a, unit) I.matching -> Location.t -> unit -> _ = fun matching loc () -> - let title = (thunk "missing case in match") in + let title = (thunk "redundant case in match") in let message () = "" in let data = [ ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;