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

Refactoring to bring local builds of the parsers closer to the global build.

Browse Source 
Added --expr to parse expressions.
This commit is contained in:
Christian Rinderknecht 2020-01-14 01:27:35 +01:00
parent 6bf91538c4
commit 9570caac53
38 changed files with 724 additions and 384 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
src/passes/1-parser/cameligo.ml
View File

@ -18,7 +18,7 @@ module Errors = struct
] in
error ~data title message
let parser_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let parser_error source (start: Lexing.position) (stop: Lexing.position) lexbuf =
let title () = "parser error" in
let file = if source = "" then
""
@ -29,18 +29,18 @@ module Errors = struct
"Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
stop.pos_lnum (stop.pos_cnum - stop.pos_bol)
file
in
let message () = str in
let loc = if start.pos_cnum = -1 then
Region.make
~start: Pos.min
~stop:(Pos.from_byte end_)
~stop:(Pos.from_byte stop)
else
Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
~stop:(Pos.from_byte stop)
in
let data =
[
@ -51,7 +51,7 @@ module Errors = struct
in
error ~data title message
let unrecognized_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let unrecognized_error source (start: Lexing.position) (stop: Lexing.position) lexbuf =
let title () = "unrecognized error" in
let file = if source = "" then
""
@ -62,13 +62,13 @@ module Errors = struct
"Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
stop.pos_lnum (stop.pos_cnum - stop.pos_bol)
file
in
let message () = str in
let loc = Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
~stop:(Pos.from_byte stop)
in
let data = [
("unrecognized_loc",
@ -91,15 +91,15 @@ let parse (parser: 'a parser) source lexbuf =
with
| Parser.Error ->
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
fail @@ (parser_error source start end_ lexbuf)
let stop = Lexing.lexeme_end_p lexbuf in
fail @@ (parser_error source start stop lexbuf)
| Lexer.Error e ->
fail @@ (lexer_error e)
| _ ->
let _ = Printexc.print_backtrace Pervasives.stdout in
let start = Lexing.lexeme_start_p lexbuf in
let end_ = Lexing.lexeme_end_p lexbuf in
fail @@ (unrecognized_error source start end_ lexbuf)
let stop = Lexing.lexeme_end_p lexbuf in
fail @@ (unrecognized_error source start stop lexbuf)
in
close ();
result
@ -122,8 +122,8 @@ let parse_file (source: string) : AST.t result =
let parse_string (s:string) : AST.t result =
let lexbuf = Lexing.from_string s in
parse (Parser.contract) "" lexbuf
parse Parser.contract "" lexbuf
let parse_expression (s:string) : AST.expr result =
let lexbuf = Lexing.from_string s in
parse (Parser.interactive_expr) "" lexbuf
parse Parser.interactive_expr "" lexbuf

0
src/passes/1-parser/cameligo/.unlexer.tag → src/passes/1-parser/cameligo/.Unlexer.tag
View File

5
src/passes/1-parser/cameligo/Makefile.cfg Normal file
View File

@ -0,0 +1,5 @@
SHELL := dash
BFLAGS := -strict-sequence -w +A-48-4 -g
clean::
> rm -f Parser.msg Parser.msg.map Parser.msg.states Version.ml

10
src/passes/1-parser/cameligo/Parser.mly
View File

@ -119,6 +119,7 @@ declaration:
type_decl:
"type" type_name "=" type_expr {
Scoping.check_reserved_name $2;
let region = cover $1 (type_expr_to_region $4) in
let value = {
kwd_type = $1;
@ -175,6 +176,7 @@ type_tuple:
sum_type:
ioption("|") nsepseq(variant,"|") {
Scoping.check_variants (Utils.nsepseq_to_list $2);
let region = nsepseq_to_region (fun x -> x.region) $2
in TSum {region; value=$2} }
@ -188,6 +190,8 @@ variant:
record_type:
"{" sep_or_term_list(field_decl,";") "}" {
let ne_elements, terminator = $2 in
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {compound = Braces ($1,$3); ne_elements; terminator}
in TRecord {region; value} }
@ -213,9 +217,11 @@ let_declaration:
let_binding:
"<ident>" nseq(sub_irrefutable) type_annotation? "=" expr {
let binders = Utils.nseq_cons (PVar $1) $2 in
Utils.nseq_iter Scoping.check_pattern binders;
{binders; lhs_type=$3; eq=$4; let_rhs=$5}
}
| irrefutable type_annotation? "=" expr {
Scoping.check_pattern $1;
{binders=$1,[]; lhs_type=$2; eq=$3; let_rhs=$4} }
type_annotation:
@ -440,7 +446,9 @@ cases(right_expr):
in fst_case, ($2,snd_case)::others }
case_clause(right_expr):
pattern "->" right_expr { {pattern=$1; arrow=$2; rhs=$3} }
pattern "->" right_expr {
Scoping.check_pattern $1;
{pattern=$1; arrow=$2; rhs=$3} }
let_expr(right_expr):
"let" let_binding "in" right_expr {

3
src/passes/1-parser/cameligo/ParserLog.mli
View File

@ -25,6 +25,7 @@ val pattern_to_string :
val expr_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.expr -> string
(** {1 Pretty-printing of the AST} *)
(** {1 Pretty-printing of AST nodes} *)
val pp_ast : state -> AST.t -> unit
val pp_expr : state -> AST.expr -> unit

74
src/passes/1-parser/cameligo/ParserMain.ml
View File

@ -6,22 +6,86 @@ module IO =
let options = EvalOpt.read "CameLIGO" ext
end
module ExtParser =
module Parser =
struct
type ast = AST.t
type expr = AST.expr
include Parser
end
module ExtParserLog =
module ParserLog =
struct
type ast = AST.t
type expr = AST.expr
include ParserLog
end
module MyLexer = Lexer.Make (LexToken)
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (IO)(MyLexer)(AST)(ExtParser)(ParErr)(ExtParserLog)
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO)
let () = Unit.run ()
(* Main *)
let issue_error point =
let error = Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in (Unit.close_all (); Stdlib.Error error)
let parse (parser: unit -> ('a,string) Stdlib.result) : ('a,string) Stdlib.result =
try parser () with
(* Scoping errors *)
| Scoping.Error (Scoping.Reserved_name name) ->
let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
issue_error
("Reserved name.\nHint: Change the name.\n", None, invalid))
| Scoping.Error (Scoping.Duplicate_variant name) ->
let token =
Lexer.Token.mk_constr name.Region.value name.Region.region in
let point = "Duplicate constructor in this sum type declaration.\n\
Hint: Change the constructor.\n",
None, token
in issue_error point
| Scoping.Error (Scoping.Non_linear_pattern var) ->
let token =
Lexer.Token.mk_ident var.Region.value var.Region.region in
(match token with
(* Cannot fail because [var] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Repeated variable in this pattern.\n\
Hint: Change the name.\n",
None, invalid
in issue_error point)
| Scoping.Error (Scoping.Duplicate_field name) ->
let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Duplicate field name in this record declaration.\n\
Hint: Change the name.\n",
None, invalid
in issue_error point)
let () =
if IO.options#expr
then match parse (fun () -> Unit.parse Unit.parse_expr) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
else match parse (fun () -> Unit.parse Unit.parse_contract) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg

132
src/passes/1-parser/cameligo/Scoping.ml Normal file
View File

@ -0,0 +1,132 @@
[@@@warning "-42"]
type t =
Reserved_name of AST.variable
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
type error = t
exception Error of t
open Region
(* Useful modules *)
module SSet = Utils.String.Set
module Ord =
struct
type t = AST.variable
let compare v1 v2 =
compare v1.value v2.value
end
module VarSet = Set.Make (Ord)
(* Checking the definition of reserved names (shadowing) *)
let reserved =
let open SSet in
empty
|> add "assert"
|> add "balance"
|> add "time"
|> add "amount"
|> add "gas"
|> add "sender"
|> add "source"
|> add "failwith"
|> add "continue"
|> add "stop"
|> add "int"
|> add "abs"
|> add "unit"
let check_reserved_names vars =
let is_reserved elt = SSet.mem elt.value reserved in
let inter = VarSet.filter is_reserved vars in
if not (VarSet.is_empty inter) then
let clash = VarSet.choose inter in
raise (Error (Reserved_name clash))
else vars
let check_reserved_name var =
if SSet.mem var.value reserved then
raise (Error (Reserved_name var))
(* Checking the linearity of patterns *)
open! AST
let rec vars_of_pattern env = function
PConstr p -> vars_of_pconstr env p
| PUnit _ | PFalse _ | PTrue _
| PInt _ | PNat _ | PBytes _
| PString _ | PWild _ -> env
| PVar var ->
if VarSet.mem var env then
raise (Error (Non_linear_pattern var))
else VarSet.add var env
| PList l -> vars_of_plist env l
| PTuple t -> Utils.nsepseq_foldl vars_of_pattern env t.value
| PPar p -> vars_of_pattern env p.value.inside
| PRecord p -> vars_of_fields env p.value.ne_elements
| PTyped p -> vars_of_pattern env p.value.pattern
and vars_of_fields env fields =
Utils.nsepseq_foldl vars_of_field_pattern env fields
and vars_of_field_pattern env field =
let var = field.value.field_name in
if VarSet.mem var env then
raise (Error (Non_linear_pattern var))
else
let p = field.value.pattern
in vars_of_pattern (VarSet.add var env) p
and vars_of_pconstr env = function
PNone _ -> env
| PSomeApp {value=_, pattern; _} ->
vars_of_pattern env pattern
| PConstrApp {value=_, Some pattern; _} ->
vars_of_pattern env pattern
| PConstrApp {value=_,None; _} -> env
and vars_of_plist env = function
PListComp {value; _} ->
Utils.sepseq_foldl vars_of_pattern env value.elements
| PCons {value; _} ->
let head, _, tail = value in
List.fold_left vars_of_pattern env [head; tail]
let check_linearity = vars_of_pattern VarSet.empty
(* Checking patterns *)
let check_pattern p =
check_linearity p |> check_reserved_names |> ignore
(* Checking variants for duplicates *)
let check_variants variants =
let add acc {value; _} =
if VarSet.mem value.constr acc then
raise (Error (Duplicate_variant value.constr))
else VarSet.add value.constr acc in
let variants =
List.fold_left add VarSet.empty variants
in ignore variants
(* Checking record fields *)
let check_fields fields =
let add acc {value; _} =
if VarSet.mem (value: field_decl).field_name acc then
raise (Error (Duplicate_field value.field_name))
else VarSet.add value.field_name acc in
let fields =
List.fold_left add VarSet.empty fields
in ignore fields

16
src/passes/1-parser/cameligo/Scoping.mli Normal file
View File

@ -0,0 +1,16 @@
(* This module exports checks on scoping, called from the parser. *)
type t =
Reserved_name of AST.variable
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
type error = t
exception Error of t
val check_reserved_name : AST.variable -> unit
val check_pattern : AST.pattern -> unit
val check_variants : AST.variant Region.reg list -> unit
val check_fields : AST.field_decl Region.reg list -> unit

5
src/passes/1-parser/cameligo/dune
View File

@ -14,7 +14,8 @@
(library
(name parser_cameligo)
(public_name ligo.parser.cameligo)
(modules AST cameligo Parser ParserLog LexToken)
(modules
Scoping AST cameligo Parser ParserLog LexToken)
(libraries
menhirLib
parser_shared
@ -67,6 +68,6 @@
;; Build of all the LIGO source file that cover all error states
(rule
(targets all.ligo)
(targets all.mligo)
(deps (:script_cover ../../../../vendors/ligo-utils/simple-utils/cover.sh) Parser.mly LexToken.mli ParToken.mly Parser.msg Unlexer.exe)
(action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=mligo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly )))

9
src/passes/1-parser/dune
View File

@ -7,10 +7,7 @@
parser_shared
parser_pascaligo
parser_cameligo
parser_reasonligo
)
parser_reasonligo)
(preprocess
(pps ppx_let bisect_ppx --conditional)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared))
)
(pps ppx_let bisect_ppx --conditional))
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Parser_shared)))

12
src/passes/1-parser/pascaligo.ml
View File

@ -2,10 +2,10 @@ open Trace
module Parser = Parser_pascaligo.Parser
module AST = Parser_pascaligo.AST
module ParserLog = Parser_pascaligo.ParserLog
(*module ParserLog = Parser_pascaligo.ParserLog*)
module LexToken = Parser_pascaligo.LexToken
module Lexer = Lexer.Make(LexToken)
module SyntaxError = Parser_pascaligo.SyntaxError
module Scoping = Parser_pascaligo.Scoping
module Errors = struct
@ -127,13 +127,13 @@ let parse (parser: 'a parser) source lexbuf =
try
ok (parser read lexbuf)
with
SyntaxError.Error (Non_linear_pattern var) ->
Scoping.Error (Scoping.Non_linear_pattern var) ->
fail @@ (non_linear_pattern var)
| SyntaxError.Error (Duplicate_parameter name) ->
| Scoping.Error (Duplicate_parameter name) ->
fail @@ (duplicate_parameter name)
| SyntaxError.Error (Duplicate_variant name) ->
| Scoping.Error (Duplicate_variant name) ->
fail @@ (duplicate_variant name)
| SyntaxError.Error (Reserved_name name) ->
| Scoping.Error (Reserved_name name) ->
fail @@ (reserved_name name)
| Parser.Error ->
let start = Lexing.lexeme_start_p lexbuf in

25
src/passes/1-parser/pascaligo.mli
View File

@ -1,21 +1,18 @@
(* This file provides an interface to the PascaLIGO parser. *)
(** This file provides an interface to the PascaLIGO parser. *)
open Trace
module Parser = Parser_pascaligo.Parser
module AST = Parser_pascaligo.AST
module ParserLog = Parser_pascaligo.ParserLog
module LexToken = Parser_pascaligo.LexToken
(** Open a PascaLIGO filename given by string and convert into an abstract syntax tree. *)
val parse_file : string -> (AST.t result)
(** Open a PascaLIGO filename given by string and convert into an
abstract syntax tree. *)
val parse_file : string -> AST.t Trace.result
(** Convert a given string into a PascaLIGO abstract syntax tree *)
val parse_string : string -> AST.t result
val parse_string : string -> AST.t Trace.result
(** Parse a given string as a PascaLIGO expression and return an expression AST.
(** Parse a given string as a PascaLIGO expression and return an
expression AST.
This is intended to be used for interactive interpreters, or other scenarios
where you would want to parse a PascaLIGO expression outside of a contract. *)
val parse_expression : string -> AST.expr result
This is intended to be used for interactive interpreters, or other
scenarios where you would want to parse a PascaLIGO expression
outside of a contract. *)
val parse_expression : string -> AST.expr Trace.result

0
src/passes/1-parser/pascaligo/.unlexer.tag → src/passes/1-parser/pascaligo/.Unlexer.tag
View File

0
src/passes/1-parser/pascaligo/SParserMain.ml → src/passes/1-parser/pascaligo/Misc/SParserMain.ml
View File

42
src/passes/1-parser/pascaligo/Parser.mly
View File

@ -118,7 +118,7 @@ declaration:
type_decl:
"type" type_name "is" type_expr ";"? {
ignore (SyntaxError.check_reserved_name $2);
Scoping.check_reserved_name $2;
let stop =
match $5 with
Some region -> region
@ -186,7 +186,7 @@ type_tuple:
sum_type:
"|"? nsepseq(variant,"|") {
SyntaxError.check_variants (Utils.nsepseq_to_list $2);
Scoping.check_variants (Utils.nsepseq_to_list $2);
let region = nsepseq_to_region (fun x -> x.region) $2
in TSum {region; value=$2} }
@ -201,7 +201,7 @@ record_type:
"record" sep_or_term_list(field_decl,";") "end" {
let ne_elements, terminator = $2 in
let () = Utils.nsepseq_to_list ne_elements
|> SyntaxError.check_fields in
|> Scoping.check_fields in
let region = cover $1 $3
and value = {opening = Kwd $1;
ne_elements;
@ -243,11 +243,11 @@ open_fun_decl:
"function" fun_name parameters ":" type_expr "is"
block
"with" expr {
let fun_name = SyntaxError.check_reserved_name $2 in
Scoping.check_reserved_name $2;
let stop = expr_to_region $9 in
let region = cover $1 stop
and value = {kwd_function = $1;
fun_name;
fun_name = $2;
param = $3;
colon = $4;
ret_type = $5;
@ -257,11 +257,11 @@ open_fun_decl:
terminator = None}
in {region; value} }
| "function" fun_name parameters ":" type_expr "is" expr {
let fun_name = SyntaxError.check_reserved_name $2 in
Scoping.check_reserved_name $2;
let stop = expr_to_region $7 in
let region = cover $1 stop
and value = {kwd_function = $1;
fun_name;
fun_name = $2;
param = $3;
colon = $4;
ret_type = $5;
@ -279,26 +279,26 @@ parameters:
par(nsepseq(param_decl,";")) {
let params =
Utils.nsepseq_to_list ($1.value: _ par).inside
in SyntaxError.check_parameters params;
in Scoping.check_parameters params;
$1 }
param_decl:
"var" var ":" param_type {
let var = SyntaxError.check_reserved_name $2 in
Scoping.check_reserved_name $2;
let stop = type_expr_to_region $4 in
let region = cover $1 stop
and value = {kwd_var = $1;
var;
var = $2;
colon = $3;
param_type = $4}
in ParamVar {region; value}
}
| "const" var ":" param_type {
let var = SyntaxError.check_reserved_name $2 in
Scoping.check_reserved_name $2;
let stop = type_expr_to_region $4 in
let region = cover $1 stop
and value = {kwd_const = $1;
var;
var = $2;
colon = $3;
param_type = $4}
in ParamConst {region; value} }
@ -362,9 +362,9 @@ open_var_decl:
unqualified_decl(OP):
var ":" type_expr OP expr {
let var = SyntaxError.check_reserved_name $1 in
Scoping.check_reserved_name $1;
let region = expr_to_region $5
in var, $2, $3, $4, $5, region }
in $1, $2, $3, $4, $5, region }
const_decl:
open_const_decl ";"? {
@ -571,7 +571,7 @@ cases(rhs):
case_clause(rhs):
pattern "->" rhs {
SyntaxError.check_pattern $1;
Scoping.check_pattern $1;
fun rhs_to_region ->
let start = pattern_to_region $1 in
let region = cover start (rhs_to_region $3)
@ -613,10 +613,10 @@ for_loop:
in For (ForInt {region; value})
}
| "for" var arrow_clause? "in" collection expr block {
let var = SyntaxError.check_reserved_name $2 in
Scoping.check_reserved_name $2;
let region = cover $1 $7.region in
let value = {kwd_for = $1;
var;
var = $2;
bind_to = $3;
kwd_in = $4;
collection = $5;
@ -631,13 +631,13 @@ collection:
var_assign:
var ":=" expr {
let name = SyntaxError.check_reserved_name $1 in
let region = cover name.region (expr_to_region $3)
and value = {name; assign=$2; expr=$3}
Scoping.check_reserved_name $1;
let region = cover $1.region (expr_to_region $3)
and value = {name=$1; assign=$2; expr=$3}
in {region; value} }
arrow_clause:
"->" var { $1, SyntaxError.check_reserved_name $2 }
"->" var { Scoping.check_reserved_name $2; ($1,$2) }
(* Expressions *)

4
src/passes/1-parser/pascaligo/ParserLog.mli
View File

@ -18,6 +18,7 @@ val print_tokens : state -> AST.t -> unit
val print_path : state -> AST.path -> unit
val print_pattern : state -> AST.pattern -> unit
val print_instruction : state -> AST.instruction -> unit
val print_expr : state -> AST.expr -> unit
(** {1 Printing tokens from the AST in a string} *)
@ -30,6 +31,7 @@ val pattern_to_string :
val instruction_to_string :
offsets:bool -> mode:[`Point|`Byte] -> AST.instruction -> string
(** {1 Pretty-printing of the AST} *)
(** {1 Pretty-printing of AST nodes} *)
val pp_ast : state -> AST.t -> unit
val pp_expr : state -> AST.expr -> unit

117
src/passes/1-parser/pascaligo/ParserMain.ml
View File

@ -6,100 +6,97 @@ module IO =
let options = EvalOpt.read "PascaLIGO" ext
end
module ExtParser =
module Parser =
struct
type ast = AST.t
type expr = AST.expr
include Parser
end
module ExtParserLog =
module ParserLog =
struct
type ast = AST.t
type expr = AST.expr
include ParserLog
end
module MyLexer = Lexer.Make (LexToken)
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (IO)(MyLexer)(AST)(ExtParser)(ParErr)(ExtParserLog)
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO)
open! SyntaxError
(* Main *)
let () =
try Unit.run () with
(* Ad hoc errors from the parser *)
let issue_error point =
let error = Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in (Unit.close_all (); Stdlib.Error error)
Error (Reserved_name name) ->
let () = Unit.close_all () in
let parse (parser: unit -> ('a,string) Stdlib.result) : ('a,string) Stdlib.result =
try parser () with
(* Scoping errors *)
| Scoping.Error (Scoping.Duplicate_parameter name) ->
let token =
MyLexer.Token.mk_ident name.Region.value name.Region.region in
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
Stdlib.Error _ ->
assert false (* Should not fail if [name] is valid. *)
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Reserved name.\nHint: Change the name.\n",
None, invalid in
let error =
Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in Printf.eprintf "\027[31m%s\027[0m%!" error)
issue_error ("Duplicate parameter.\nHint: Change the name.\n",
None, invalid))
| Error (Duplicate_parameter name) ->
let () = Unit.close_all () in
| Scoping.Error (Scoping.Reserved_name name) ->
let token =
MyLexer.Token.mk_ident name.Region.value name.Region.region in
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
Stdlib.Error _ ->
assert false (* Should not fail if [name] is valid. *)
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Duplicate parameter.\nHint: Change the name.\n",
None, invalid in
let error =
Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in Printf.eprintf "\027[31m%s\027[0m%!" error)
issue_error
("Reserved name.\nHint: Change the name.\n", None, invalid))
| Error (Duplicate_variant name) ->
let () = Unit.close_all () in
| Scoping.Error (Scoping.Duplicate_variant name) ->
let token =
MyLexer.Token.mk_constr name.Region.value name.Region.region in
let point = "Duplicate variant in this sum type declaration.\n\
Hint: Change the name.\n",
None, token in
let error =
Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in Printf.eprintf "\027[31m%s\027[0m%!" error
Lexer.Token.mk_constr name.Region.value name.Region.region in
let point = "Duplicate constructor in this sum type declaration.\n\
Hint: Change the constructor.\n",
None, token
in issue_error point
| Error (Non_linear_pattern var) ->
let () = Unit.close_all () in
| Scoping.Error (Scoping.Non_linear_pattern var) ->
let token =
MyLexer.Token.mk_ident var.Region.value var.Region.region in
Lexer.Token.mk_ident var.Region.value var.Region.region in
(match token with
Stdlib.Error _ ->
assert false (* Should not fail if [name] is valid. *)
(* Cannot fail because [var] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Repeated variable in this pattern.\n\
Hint: Change the name.\n",
None, invalid in
let error =
Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in Printf.eprintf "\027[31m%s\027[0m%!" error)
None, invalid
in issue_error point)
| Error (Duplicate_field name) ->
let () = Unit.close_all () in
| Scoping.Error (Scoping.Duplicate_field name) ->
let token =
MyLexer.Token.mk_ident name.Region.value name.Region.region in
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
Stdlib.Error _ ->
assert false (* Should not fail if [name] is valid. *)
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Duplicate field name in this record declaration.\n\
Hint: Change the name.\n",
None, invalid in
let error =
Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in Printf.eprintf "\027[31m%s\027[0m%!" error)
None, invalid
in issue_error point)
let () =
if IO.options#expr
then match parse (fun () -> Unit.parse Unit.parse_expr) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
else match parse (fun () -> Unit.parse Unit.parse_contract) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg

1
src/passes/1-parser/pascaligo/SyntaxError.ml → src/passes/1-parser/pascaligo/Scoping.ml
View File

@ -95,7 +95,6 @@ let check_reserved_names vars =
let check_reserved_name var =
if SSet.mem var.value reserved then
raise (Error (Reserved_name var))
else var
(* Checking the linearity of patterns *)

18
src/passes/1-parser/pascaligo/Scoping.mli Normal file
View File

@ -0,0 +1,18 @@
(* This module exports checks on scoping, called from the parser. *)
type t =
Reserved_name of AST.variable
| Duplicate_parameter of AST.variable
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
type error = t
exception Error of t
val check_reserved_name : AST.variable -> unit
val check_pattern : AST.pattern -> unit
val check_variants : AST.variant Region.reg list -> unit
val check_parameters : AST.param_decl list -> unit
val check_fields : AST.field_decl Region.reg list -> unit

27
src/passes/1-parser/pascaligo/SyntaxError.mli
View File

@ -1,27 +0,0 @@
(* This module exports checks on scoping, called from the parser. *)
type t =
Reserved_name of AST.variable
| Duplicate_parameter of AST.variable
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
type error = t
exception Error of t
module Ord :
sig
type t = AST.variable
val compare : t -> t -> int
end
module VarSet : Set.S with type elt = Ord.t
val check_reserved_name : AST.variable -> AST.variable
val check_reserved_names : VarSet.t -> VarSet.t
val check_pattern : AST.pattern -> unit
val check_variants : AST.variant Region.reg list -> unit
val check_parameters : AST.param_decl list -> unit
val check_fields : AST.field_decl Region.reg list -> unit

4
src/passes/1-parser/pascaligo/Tests/pp.ligo
View File

@ -61,12 +61,12 @@ function claim (var store : store) : list (operation) * store is
case store.backers[sender] of
None ->
failwith ("Not a backer.")
| Some (amount) ->
| Some (quantity) ->
if balance >= store.goal or store.funded then
failwith ("Goal reached: no refund.")
else
begin
operations.0.foo := list [transaction (unit, sender, amount)];
operations.0.foo := list [transaction (unit, sender, quantity)];
remove sender from map store.backers
end
end

4
src/passes/1-parser/pascaligo/dune
View File

@ -15,7 +15,7 @@
(name parser_pascaligo)
(public_name ligo.parser.pascaligo)
(modules
SyntaxError AST pascaligo Parser ParserLog LexToken)
Scoping AST pascaligo Parser ParserLog LexToken ParErr)
(libraries
menhirLib
parser_shared
@ -53,7 +53,7 @@
(name ParserMain)
(libraries parser_pascaligo)
(modules
ParErr ParserMain)
ParserMain)
(preprocess
(pps bisect_ppx --conditional))
(flags (:standard -open Simple_utils -open Parser_shared -open Parser_pascaligo)))

4
src/passes/1-parser/pascaligo/pascaligo.ml
View File

@ -1,5 +1,5 @@
module Parser = Parser
module AST = AST
module Lexer = Lexer
module LexToken = LexToken
module AST = AST
module Parser = Parser
module ParserLog = ParserLog

75
src/passes/1-parser/reasonligo.ml
View File

@ -6,18 +6,17 @@ module ParserLog = Parser_cameligo.ParserLog
module LexToken = Parser_reasonligo.LexToken
module Lexer = Lexer.Make(LexToken)
module SyntaxError = Parser_reasonligo.SyntaxError
module Scoping = Parser_cameligo.Scoping
module Errors = struct
module Errors =
struct
let lexer_error (e: Lexer.error AST.reg) =
let title () = "lexer error" in
let message () = Lexer.error_to_string e.value in
let data = [
("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region
)
] in
error ~data title message
fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region)]
in error ~data title message
let wrong_function_arguments expr =
let title () = "wrong function arguments" in
@ -25,68 +24,58 @@ module Errors = struct
let expression_loc = AST.expr_to_region expr in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)
] in
error ~data title message
fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)]
in error ~data title message
let parser_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let parser_error source (start: Lexing.position)
(end_: Lexing.position) lexbuf =
let title () = "parser error" in
let file = if source = "" then
""
let file =
if source = "" then ""
else
Format.sprintf "In file \"%s|%s\"" start.pos_fname source
in
let str = Format.sprintf
Format.sprintf "In file \"%s|%s\"" start.pos_fname source in
let str =
Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
file
in
file in
let message () = str in
let loc = if start.pos_cnum = -1 then
Region.make
let loc =
if start.pos_cnum = -1
then Region.make
~start: Pos.min
~stop:(Pos.from_byte end_)
else
Region.make
else Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
in
~stop:(Pos.from_byte end_) in
let data =
[
("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc
)
]
in
error ~data title message
[("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)]
in error ~data title message
let unrecognized_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let title () = "unrecognized error" in
let file = if source = "" then
""
let file =
if source = "" then ""
else
Format.sprintf "In file \"%s|%s\"" start.pos_fname source
in
let str = Format.sprintf
Format.sprintf "In file \"%s|%s\"" start.pos_fname source in
let str =
Format.sprintf
"Parse error at \"%s\" from (%d, %d) to (%d, %d). %s\n"
(Lexing.lexeme lexbuf)
start.pos_lnum (start.pos_cnum - start.pos_bol)
end_.pos_lnum (end_.pos_cnum - end_.pos_bol)
file
in
file in
let message () = str in
let loc = Region.make
~start:(Pos.from_byte start)
~stop:(Pos.from_byte end_)
in
~stop:(Pos.from_byte end_) in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc
)
] in
error ~data title message
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)]
in error ~data title message
end

0
src/passes/1-parser/reasonligo/.unlexer.tag → src/passes/1-parser/reasonligo/.Unlexer.tag
View File

2
src/passes/1-parser/reasonligo/.links
View File

@ -24,3 +24,5 @@ Stubs/Parser_cameligo.ml
../cameligo/AST.ml
../cameligo/ParserLog.mli
../cameligo/ParserLog.ml
../cameligo/Scoping.mli
../cameligo/Scoping.ml

25
src/passes/1-parser/reasonligo/Parser.mly
View File

@ -148,6 +148,7 @@ declaration:
type_decl:
"type" type_name "=" type_expr {
Scoping.check_reserved_name $2;
let region = cover $1 (type_expr_to_region $4)
and value = {kwd_type = $1;
name = $2;
@ -192,6 +193,7 @@ core_type:
sum_type:
"|" nsepseq(variant,"|") {
Scoping.check_variants (Utils.nsepseq_to_list $2);
let region = nsepseq_to_region (fun x -> x.region) $2
in TSum {region; value=$2} }
@ -205,6 +207,8 @@ variant:
record_type:
"{" sep_or_term_list(field_decl,",") "}" {
let ne_elements, terminator = $2 in
let () = Utils.nsepseq_to_list ne_elements
|> Scoping.check_fields in
let region = cover $1 $3
and value = {compound = Braces ($1,$3); ne_elements; terminator}
in TRecord {region; value} }
@ -239,21 +243,25 @@ es6_func:
let_binding:
"<ident>" type_annotation? "=" expr {
{binders = PVar $1,[]; lhs_type=$2; eq=$3; let_rhs=$4}
Scoping.check_reserved_name $1;
{binders = PVar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| "_" type_annotation? "=" expr {
{binders = PWild $1,[]; lhs_type=$2; eq=$3; let_rhs=$4}
{binders = PWild $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| unit type_annotation? "=" expr {
{binders = PUnit $1,[]; lhs_type=$2; eq=$3; let_rhs=$4}
{binders = PUnit $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| record_pattern type_annotation? "=" expr {
Scoping.check_pattern (PRecord $1);
{binders = PRecord $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| par(closed_irrefutable) type_annotation? "=" expr {
Scoping.check_pattern $1.value.inside;
{binders = PPar $1, []; lhs_type=$2; eq=$3; let_rhs=$4}
}
| tuple(sub_irrefutable) type_annotation? "=" expr {
Utils.nsepseq_iter Scoping.check_pattern $1;
let hd, tl = $1 in
let start = pattern_to_region hd in
let stop = last fst tl in
@ -417,8 +425,11 @@ fun_expr:
let region = cover start stop in
let rec arg_to_pattern = function
EVar v -> PVar v
EVar v ->
Scoping.check_reserved_name v;
PVar v
| EAnnot {region; value = {inside = EVar v, colon, typ; _}} ->
Scoping.check_reserved_name v;
let value = {pattern = PVar v; colon; type_expr = typ}
in PTyped {region; value}
| EPar p ->
@ -452,8 +463,9 @@ fun_expr:
arg_to_pattern (EAnnot e), []
| ETuple {value = fun_args; _} ->
let bindings =
List.map (arg_to_pattern <@ snd) (snd fun_args)
in arg_to_pattern (fst fun_args), bindings
List.map (arg_to_pattern <@ snd) (snd fun_args) in
List.iter Scoping.check_pattern bindings;
arg_to_pattern (fst fun_args), bindings
| EUnit e ->
arg_to_pattern (EUnit e), []
| e -> let open! SyntaxError
@ -538,6 +550,7 @@ cases(right_expr):
case_clause(right_expr):
"|" pattern "=>" right_expr ";"? {
Scoping.check_pattern $2;
let start = pattern_to_region $2
and stop = expr_to_region $4 in
let region = cover start stop

79
src/passes/1-parser/reasonligo/ParserMain.ml
View File

@ -6,32 +6,37 @@ module IO =
let options = EvalOpt.read "ReasonLIGO" ext
end
module ExtParser =
module Parser =
struct
type ast = AST.t
type expr = AST.expr
include Parser
end
module ExtParserLog =
module ParserLog =
struct
type ast = AST.t
type expr = AST.expr
include ParserLog
end
module MyLexer = Lexer.Make (LexToken)
module Lexer = Lexer.Make (LexToken)
module Unit =
ParserUnit.Make (IO)(MyLexer)(AST)(ExtParser)(ParErr)(ExtParserLog)
ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)(IO)
(* Main *)
let () =
try Unit.run () with
(* Ad hoc errors from the parsers *)
let issue_error point =
let error = Unit.format_error ~offsets:IO.options#offsets
IO.options#mode point
in (Unit.close_all (); Stdlib.Error error)
let parse (parser: unit -> ('a,string) Stdlib.result) : ('a,string) Stdlib.result =
try parser () with
(* Ad hoc errors from the parser *)
SyntaxError.Error (SyntaxError.WrongFunctionArguments expr) ->
let () = Unit.close_all () in
let msg = "It looks like you are defining a function, \
however we do not\n\
understand the parameters declaration.\n\
@ -41,4 +46,60 @@ let () =
and reg = AST.expr_to_region expr in
let error = Unit.short_error ~offsets:IO.options#offsets
IO.options#mode msg reg
in Printf.eprintf "\027[31m%s\027[0m%!" error
in (Unit.close_all (); Stdlib.Error error)
(* Scoping errors *)
| Scoping.Error (Scoping.Reserved_name name) ->
let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
issue_error
("Reserved name.\nHint: Change the name.\n", None, invalid))
| Scoping.Error (Scoping.Duplicate_variant name) ->
let token =
Lexer.Token.mk_constr name.Region.value name.Region.region in
let point = "Duplicate constructor in this sum type declaration.\n\
Hint: Change the constructor.\n",
None, token
in issue_error point
| Scoping.Error (Scoping.Non_linear_pattern var) ->
let token =
Lexer.Token.mk_ident var.Region.value var.Region.region in
(match token with
(* Cannot fail because [var] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Repeated variable in this pattern.\n\
Hint: Change the name.\n",
None, invalid
in issue_error point)
| Scoping.Error (Scoping.Duplicate_field name) ->
let token =
Lexer.Token.mk_ident name.Region.value name.Region.region in
(match token with
(* Cannot fail because [name] is a not a
reserved name for the lexer. *)
Stdlib.Error _ -> assert false
| Ok invalid ->
let point = "Duplicate field name in this record declaration.\n\
Hint: Change the name.\n",
None, invalid
in issue_error point)
let () =
if IO.options#expr
then match parse (fun () -> Unit.parse Unit.parse_expr) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg
else match parse (fun () -> Unit.parse Unit.parse_contract) with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg

2
src/passes/1-parser/reasonligo/dune
View File

@ -71,6 +71,6 @@
;; Build of all the LIGO source file that cover all error states
(rule
(targets all.ligo)
(targets all.religo)
(deps (:script_cover ../../../../vendors/ligo-utils/simple-utils/cover.sh) Parser.mly LexToken.mli ParToken.mly Parser.msg Unlexer.exe)
(action (run %{script_cover} --lex-tokens=LexToken.mli --par-tokens=ParToken.mly --ext=religo --unlexer=./Unlexer.exe --messages=Parser.msg --dir=. --concatenate Parser.mly )))

26
src/passes/1-parser/shared/EvalOpt.ml
View File

@ -14,10 +14,11 @@ type options = <
offsets : bool;
mode : [`Byte | `Point];
cmd : command;
mono : bool
mono : bool;
expr : bool
>
let make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono =
let make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono ~expr =
object
method input = input
method libs = libs
@ -26,6 +27,7 @@ let make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono =
method mode = mode
method cmd = cmd
method mono = mono
method expr = expr
end
(** {1 Auxiliary functions} *)
@ -42,7 +44,7 @@ let abort msg =
let help language extension () =
let file = Filename.basename Sys.argv.(0) in
printf "Usage: %s [<option> ...] [<input>%s | \"-\"]\n" file extension;
printf "where <input>%s is the %s source file (default: stdin)," extension language;
printf "where <input>%s is the %s source file (default: stdin),\n" extension language;
print "and each <option> (if any) is one of the following:";
print " -I <paths> Library paths (colon-separated)";
print " -c, --copy Print lexemes of tokens and markup (lexer)";
@ -52,7 +54,8 @@ let help language extension () =
print " --columns Columns for source locations";
print " --bytes Bytes for source locations";
print " --mono Use Menhir monolithic API";
print " --verbose=<stages> cmdline, cpp, ast-tokens, ast (colon-separated)";
print " --expr Parse an expression";
print " --verbose=<stages> cli, cpp, ast-tokens, ast (colon-separated)";
print " --version Commit hash on stdout";
print " -h, --help This help";
exit 0
@ -74,6 +77,7 @@ and input = ref None
and libs = ref []
and verb_str = ref ""
and mono = ref false
and expr = ref false
let split_at_colon = Str.(split (regexp ":"))
@ -94,6 +98,7 @@ let specs language extension =
noshort, "columns", set columns true, None;
noshort, "bytes", set bytes true, None;
noshort, "mono", set mono true, None;
noshort, "expr", set expr true, None;
noshort, "verbose", None, Some add_verbose;
'h', "help", Some (help language extension), None;
noshort, "version", Some version, None
@ -129,7 +134,8 @@ let print_opt () =
printf "quiet = %b\n" !quiet;
printf "columns = %b\n" !columns;
printf "bytes = %b\n" !bytes;
printf "mono = %b\b" !mono;
printf "mono = %b\n" !mono;
printf "expr = %b\n" !expr;
printf "verbose = %s\n" !verb_str;
printf "input = %s\n" (string_of quote !input);
printf "libs = %s\n" (string_of_path !libs)
@ -137,7 +143,7 @@ let print_opt () =
let check extension =
let () =
if Utils.String.Set.mem "cmdline" !verbose then print_opt () in
if Utils.String.Set.mem "cli" !verbose then print_opt () in
let input =
match !input with
@ -158,11 +164,12 @@ let check extension =
and offsets = not !columns
and mode = if !bytes then `Byte else `Point
and mono = !mono
and expr = !expr
and verbose = !verbose
and libs = !libs in
let () =
if Utils.String.Set.mem "cmdline" verbose then
if Utils.String.Set.mem "cli" verbose then
begin
printf "\nEXPORTED COMMAND LINE\n";
printf "copy = %b\n" copy;
@ -172,6 +179,7 @@ let check extension =
printf "offsets = %b\n" offsets;
printf "mode = %s\n" (if mode = `Byte then "`Byte" else "`Point");
printf "mono = %b\n" mono;
printf "expr = %b\n" expr;
printf "verbose = %s\n" !verb_str;
printf "input = %s\n" (string_of quote input);
printf "libs = %s\n" (string_of_path libs)
@ -186,7 +194,7 @@ let check extension =
| false, false, false, true -> Tokens
| _ -> abort "Choose one of -q, -c, -u, -t."
in make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono
in make ~input ~libs ~verbose ~offsets ~mode ~cmd ~mono ~expr
(** {1 Parsing the command-line options} *)
@ -195,7 +203,7 @@ let read language extension =
Getopt.parse_cmdline (specs language extension) anonymous;
(verb_str :=
let apply e a =
if a <> "" then Printf.sprintf "%s, %s" e a else e
if a = "" then e else Printf.sprintf "%s, %s" e a
in Utils.String.Set.fold apply !verbose "");
check extension
with Getopt.Error msg -> abort msg

25
src/passes/1-parser/shared/EvalOpt.mli
View File

@ -1,4 +1,4 @@
(** Parsing the command-line options of PascaLIGO *)
(** Parsing the command-line options of LIGO *)
(** The type [command] denotes some possible behaviours of the
compiler. The constructors are
@ -23,12 +23,11 @@ type command = Quiet | Copy | Units | Tokens
(** The type [options] gathers the command-line options.
{ul
{li If the field [input] is [Some src], the name of the
PascaLIGO source file, with the extension ".ligo", is
[src]. If [input] is [Some "-"] or [None], the source file
is read from standard input.}
{li If the field [input] is [Some src], the name of the LIGO
source file is [src]. If [input] is [Some "-"] or [None],
the source file is read from standard input.}
{li The field [libs] is the paths where to find PascaLIGO files
{li The field [libs] is the paths where to find LIGO files
for inclusion (#include).}
{li The field [verbose] is a set of stages of the compiler
@ -41,8 +40,14 @@ type command = Quiet | Copy | Units | Tokens
{li If the value [mode] is [`Byte], then the unit in which
source positions and regions are expressed in messages is
the byte. If [`Point], the unit is unicode points.}
}
*)
{li If the field [mono] is [true], then the monolithic API of
Menhir is called, otherwise the incremental API is.}
{li If the field [expr] is [true], then the parser for
expressions is used, otherwise a full-fledged contract is
expected.}
} *)
type options = <
input : string option;
libs : string list;
@ -50,7 +55,8 @@ type options = <
offsets : bool;
mode : [`Byte | `Point];
cmd : command;
mono : bool
mono : bool;
expr : bool
>
val make :
@ -61,6 +67,7 @@ val make :
mode:[`Byte | `Point] ->
cmd:command ->
mono:bool ->
expr:bool ->
options
(** Parsing the command-line options on stdin. The first parameter is

15
src/passes/1-parser/shared/ParserAPI.ml
View File

@ -86,17 +86,28 @@ module Make (Lexer: Lexer.S)
| Lexer.Two (invalid, valid) ->
raise (Point (message, Some valid, invalid))
(* The two Menhir APIs are called from the following two functions. *)
(* The two Menhir APIs are called from the following functions. *)
module Incr = Parser.Incremental
let incr_contract Lexer.{read; buffer; get_win; close; _} : Parser.ast =
let supplier = I.lexer_lexbuf_to_supplier read buffer
and failure = failure get_win in
let parser = Parser.Incremental.contract buffer.Lexing.lex_curr_p in
let parser = Incr.contract buffer.Lexing.lex_curr_p in
let ast = I.loop_handle success failure supplier parser
in close (); ast
let mono_contract = Parser.contract
let incr_expr Lexer.{read; buffer; get_win; close; _} : Parser.expr =
let supplier = I.lexer_lexbuf_to_supplier read buffer
and failure = failure get_win in
let parser = Incr.interactive_expr buffer.Lexing.lex_curr_p in
let expr = I.loop_handle success failure supplier parser
in close (); expr
let mono_expr = Parser.interactive_expr
(* Errors *)
let format_error ?(offsets=true) mode (msg, valid_opt, invalid) =

11
src/passes/1-parser/shared/ParserAPI.mli
View File

@ -16,8 +16,10 @@ module type PARSER =
(* The monolithic API. *)
val interactive_expr : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> expr
val contract : (Lexing.lexbuf -> token) -> Lexing.lexbuf -> ast
val interactive_expr :
(Lexing.lexbuf -> token) -> Lexing.lexbuf -> expr
val contract :
(Lexing.lexbuf -> token) -> Lexing.lexbuf -> ast
(* The incremental API. *)
@ -49,6 +51,11 @@ module Make (Lexer: Lexer.S)
val incr_contract :
Lexer.instance -> Parser.ast
val mono_expr :
(Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> Parser.expr
val incr_expr :
Lexer.instance -> Parser.expr
(* Error handling *)
type message = string

122
src/passes/1-parser/shared/ParserUnit.ml
View File

@ -1,6 +1,6 @@
(* Functor to build a standalone LIGO parser *)
module type S =
module type IO =
sig
val ext : string (* LIGO file extension *)
val options : EvalOpt.options (* CLI options *)
@ -10,23 +10,27 @@ module type Pretty =
sig
type state
type ast
val pp_ast :
state -> ast -> unit
type expr
val mk_state :
offsets:bool -> mode:[`Point|`Byte] -> buffer:Buffer.t -> state
val print_tokens :
state -> ast -> unit
val pp_ast : state -> ast -> unit
val pp_expr : state -> expr -> unit
val print_tokens : state -> ast -> unit
val print_expr : state -> expr -> unit
end
module Make (IO: S)
(Lexer: Lexer.S)
module Make (Lexer: Lexer.S)
(AST: sig type t type expr end)
(Parser: ParserAPI.PARSER
with type ast = AST.t
and type expr = AST.expr
and type token = Lexer.token)
(ParErr: sig val message : int -> string end)
(ParserLog: Pretty with type ast = AST.t) =
(ParserLog: Pretty with type ast = AST.t
and type expr = AST.expr)
(IO: IO) =
struct
open Printf
@ -61,10 +65,13 @@ module Make (IO: S)
let suffix = ".pp" ^ IO.ext
module SSet = Utils.String.Set
let pp_input =
if Utils.String.Set.mem "cpp" IO.options#verbose
if SSet.mem "cpp" IO.options#verbose
then prefix ^ suffix
else let pp_input, pp_out = Filename.open_temp_file prefix suffix
else let pp_input, pp_out =
Filename.open_temp_file prefix suffix
in close_out pp_out; pp_input
let cpp_cmd =
@ -77,20 +84,20 @@ module Make (IO: S)
lib_path file pp_input
let () =
if Utils.String.Set.mem "cpp" IO.options#verbose
if SSet.mem "cpp" IO.options#verbose
then eprintf "%s\n%!" cpp_cmd;
if Sys.command cpp_cmd <> 0 then
external_ (sprintf "the command \"%s\" failed." cpp_cmd)
(* Instanciating the lexer *)
module ParserFront = ParserAPI.Make (Lexer) (Parser) (ParErr)
module ParserFront = ParserAPI.Make (Lexer)(Parser)(ParErr)
let format_error = ParserFront.format_error
let short_error = ParserFront.short_error
let lexer_inst = Lexer.open_token_stream (Some pp_input)
let Lexer.{read; buffer; get_win; get_pos; get_last; close} = lexer_inst
let Lexer.{read; buffer; get_win; close; _} = lexer_inst
and cout = stdout
@ -107,55 +114,82 @@ module Make (IO: S)
(* Main *)
let run () =
try
let output = Buffer.create 131
let state = ParserLog.mk_state
~offsets:IO.options#offsets
~mode:IO.options#mode
~buffer:output
(* Parsing an expression *)
let parse_expr () : AST.expr =
let expr =
if IO.options#mono then
ParserFront.mono_expr tokeniser buffer
else
ParserFront.incr_expr lexer_inst in
let () =
if SSet.mem "ast-tokens" IO.options#verbose
then begin
Buffer.clear output;
ParserLog.print_expr state expr;
Buffer.output_buffer stdout output
end in
let () =
if SSet.mem "ast" IO.options#verbose
then begin
Buffer.clear output;
ParserLog.pp_expr state expr;
Buffer.output_buffer stdout output
end
in expr (* Or more CLI options handled before *)
(* Parsing a contract *)
let parse_contract () : AST.t =
let ast =
if IO.options#mono
then ParserFront.mono_contract tokeniser buffer
else ParserFront.incr_contract lexer_inst in
if Utils.String.Set.mem "ast" IO.options#verbose
then let buffer = Buffer.create 131 in
let state = ParserLog.mk_state
~offsets:IO.options#offsets
~mode:IO.options#mode
~buffer in
begin
if IO.options#mono then
ParserFront.mono_contract tokeniser buffer
else
ParserFront.incr_contract lexer_inst in
let () =
if SSet.mem "ast" IO.options#verbose
then begin
Buffer.clear output;
ParserLog.pp_ast state ast;
Buffer.output_buffer stdout buffer
end
else if Utils.String.Set.mem "ast-tokens" IO.options#verbose
then let buffer = Buffer.create 131 in
let state = ParserLog.mk_state
~offsets:IO.options#offsets
~mode:IO.options#mode
~buffer in
begin
Buffer.output_buffer stdout output
end in
let () =
if SSet.mem "ast-tokens" IO.options#verbose
then begin
Buffer.clear output;
ParserLog.print_tokens state ast;
Buffer.output_buffer stdout buffer
Buffer.output_buffer stdout output
end
in ast (* Or more CLI options handled before. *)
let parse (parser: unit -> 'a) : ('a,string) Stdlib.result =
try
let node = parser () in (close_all (); Ok node)
with
(* Lexing errors *)
Lexer.Error err ->
close_all ();
let msg =
let error =
Lexer.format_error ~offsets:IO.options#offsets
IO.options#mode err ~file
in prerr_string msg
in close_all (); Stdlib.Error error
(* Incremental API of Menhir *)
| ParserFront.Point point ->
let () = close_all () in
let error =
ParserFront.format_error ~offsets:IO.options#offsets
IO.options#mode point
in eprintf "\027[31m%s\027[0m%!" error
in close_all (); Stdlib.Error error
(* Monolithic API of Menhir *)
| Parser.Error ->
let () = close_all () in
let invalid, valid_opt =
match get_win () with
Lexer.Nil ->
@ -166,10 +200,10 @@ module Make (IO: S)
let error =
ParserFront.format_error ~offsets:IO.options#offsets
IO.options#mode point
in eprintf "\027[31m%s\027[0m%!" error
in close_all (); Stdlib.Error error
(* I/O errors *)
| Sys_error msg -> Utils.highlight msg
| Sys_error error -> Stdlib.Error error
end

7
src/passes/2-simplify/dune
View File

@ -12,8 +12,5 @@
(preprocess
(pps
ppx_let
bisect_ppx --conditional
)
)
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils ))
)
bisect_ppx --conditional))
(flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils)))

7
src/passes/2-simplify/pascaligo.ml
View File

@ -4,6 +4,7 @@ open Ast_simplified
module Raw = Parser.Pascaligo.AST
module SMap = Map.String
module SSet = Set.Make (String)
module ParserLog = Parser_pascaligo.ParserLog
open Combinators
@ -132,7 +133,7 @@ module Errors = struct
fun () -> Format.asprintf "%a" Location.pp_lift @@ pattern_loc) ;
(** TODO: The labelled arguments should be flowing from the CLI. *)
("pattern",
fun () -> Parser.Pascaligo.ParserLog.pattern_to_string
fun () -> ParserLog.pattern_to_string
~offsets:true ~mode:`Point p)
] in
error ~data title message
@ -168,7 +169,7 @@ module Errors = struct
(** TODO: The labelled arguments should be flowing from the CLI. *)
let data = [
("instruction",
fun () -> Parser.Pascaligo.ParserLog.instruction_to_string
fun () -> ParserLog.instruction_to_string
~offsets:true ~mode:`Point t)
] in
error ~data title message
@ -1036,7 +1037,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> (a, unit) matching result =
(** TODO: The labelled arguments should be flowing from the CLI. *)
let content () =
Printf.sprintf "Pattern : %s"
(Parser.Pascaligo.ParserLog.pattern_to_string
(ParserLog.pattern_to_string
~offsets:true ~mode:`Point x) in
error title content in
let%bind x' =

4
src/test/dune
View File

@ -25,8 +25,8 @@
(action (run ./parser_negative_tests.exe))
(deps
../passes/1-parser/pascaligo/all.ligo
../passes/1-parser/cameligo/all.ligo
../passes/1-parser/reasonligo/all.ligo
../passes/1-parser/cameligo/all.mligo
../passes/1-parser/reasonligo/all.religo
))
(alias

4
src/test/parser_negative_tests.ml
View File

@ -6,10 +6,10 @@ let pascaligo_sdata = {
erroneous_source_file = "../passes/1-parser/pascaligo/all.ligo" ;
parser = Parser.Pascaligo.parse_expression }
let cameligo_sdata = {
erroneous_source_file = "../passes/1-parser/cameligo/all.ligo" ;
erroneous_source_file = "../passes/1-parser/cameligo/all.mligo" ;
parser = Parser.Cameligo.parse_expression }
let reasonligo_sdata = {
erroneous_source_file = "../passes/1-parser/reasonligo/all.ligo" ;
erroneous_source_file = "../passes/1-parser/reasonligo/all.religo" ;
parser = Parser.Reasonligo.parse_expression }
let get_exp_as_string filename =