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

[WIP] Refactoring of front-end.

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-01-20 10:57:07 +01:00
parent 673b54e6ae
commit 8384e3d1f7
28 changed files with 855 additions and 417 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/passes/1-parser/cameligo/AST.ml
View File

@ -312,6 +312,7 @@ and comp_expr =
| Neq of neq bin_op reg
and record = field_assign reg ne_injection
and projection = {
struct_name : variable;
selector : dot;
@ -335,6 +336,7 @@ and update = {
updates : record reg;
rbrace : rbrace;
}
and path =
Name of variable
| Path of projection reg
@ -376,7 +378,7 @@ and cond_expr = {
ifso : expr;
kwd_else : kwd_else;
ifnot : expr
}
}
(* Projecting regions from some nodes of the AST *)

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

@ -1,129 +1,148 @@
open Trace
module Parser = Parser_pascaligo.Parser
module AST = Parser_pascaligo.AST
(*module Parser = Parser_pascaligo.Parser*)
(*module ParserLog = Parser_pascaligo.ParserLog*)
module AST = Parser_pascaligo.AST
module ParErr = Parser_pascaligo.ParErr
module LexToken = Parser_pascaligo.LexToken
module Lexer = Lexer.Make(LexToken)
module Scoping = Parser_pascaligo.Scoping
module SSet = Utils.String.Set
module Errors = struct
(* Mock options. TODO: Plug in cmdliner. *)
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
let pre_options =
EvalOpt.make
~libs:[]
~verbose:SSet.empty
~offsets:true
~mode:`Point
~cmd:EvalOpt.Quiet
~mono:true (* Monolithic API of Menhir for now *)
(* ~input:None *)
(* ~expr:true *)
let reserved_name Region.{value; region} =
let title () = Printf.sprintf "reserved name \"%s\"" value in
let message () = "" in
let data = [
module Parser =
struct
type ast = AST.t
type expr = AST.expr
include Parser_pascaligo.Parser
end
module ParserLog =
struct
type ast = AST.t
type expr = AST.expr
include Parser_pascaligo.ParserLog
end
module PreUnit = ParserUnit.Make (Lexer)(AST)(Parser)(ParErr)(ParserLog)
module Front = ParserAPI.Make (Lexer)(Parser)(ParErr)
let issue_error point =
let error = Front.format_error ~offsets:true (* TODO: CLI *)
`Point (* TODO: CLI *) point
in Stdlib.Error error
module Errors =
struct
let reserved_name Region.{value; region} =
let title () = Printf.sprintf "reserved name \"%s\"" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
in error ~data title message
let non_linear_pattern Region.{value; region} =
let title () =
Printf.sprintf "repeated variable \"%s\" in this pattern" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
in error ~data title message
let duplicate_parameter Region.{value; region} =
let title () =
Printf.sprintf "duplicate parameter \"%s\"" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
in error ~data title message
let duplicate_variant Region.{value; region} =
let title () =
Printf.sprintf "duplicate variant \"%s\" in this\
type declaration" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)]
in error ~data title message
let unrecognized_error source (start: Lexing.position)
(stop: Lexing.position) lexbuf =
let title () = "unrecognized error" in
let file =
if source = "" then ""
else
Format.sprintf "In file \"%s|%s\"" start.pos_fname source in
let message () =
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)
stop.pos_lnum (stop.pos_cnum - stop.pos_bol)
file in
let loc = Region.make ~start:(Pos.from_byte start)
~stop:(Pos.from_byte stop) in
let data = [
("unrecognized_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)]
in error ~data title message
let detached_attributes (attrs: AST.attributes) =
let title () = "detached attributes" in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
fun () -> Format.asprintf "%a" Location.pp_lift @@ attrs.region)]
in error ~data title message
let non_linear_pattern Region.{value; region} =
let title () = Printf.sprintf "repeated variable \"%s\" in this pattern" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
let duplicate_parameter Region.{value; region} =
let title () = Printf.sprintf "duplicate parameter \"%s\"" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
let duplicate_variant Region.{value; region} =
let title () = Printf.sprintf "duplicate variant \"%s\" in this\
type declaration" value in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ region)
] in
error ~data title message
let detached_attributes (attrs: AST.attributes) =
let title () = "detached attributes" in
let message () = "" in
let data = [
("location",
fun () -> Format.asprintf "%a" Location.pp_lift @@ attrs.region)
] in
error ~data title message
let parser_error source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let title () = "parser error" in
let file = if source = "" then
""
else
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
let message () = str in
let loc = if start.pos_cnum = -1 then
Region.make
~start: Pos.min
~stop:(Pos.from_byte end_)
else
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 source (start: Lexing.position) (end_: Lexing.position) lexbuf =
let title () = "unrecognized error" in
let file = if source = "" then
""
else
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
let message () = str 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
let parser_error source (start: Lexing.position)
(stop: Lexing.position) lexbuf =
let title () = "parser error" in
let file =
if source = "" then ""
else
Format.sprintf "In file \"%s|%s\"" start.pos_fname source in
let message () =
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)
stop.pos_lnum (stop.pos_cnum - stop.pos_bol)
file in
let loc =
if start.pos_cnum = -1 then
Region.make ~start: Pos.min ~stop:(Pos.from_byte stop)
else
Region.make ~start:(Pos.from_byte start)
~stop:(Pos.from_byte stop) in
let data =
[("parser_loc",
fun () -> Format.asprintf "%a" Location.pp_lift @@ loc)] in
error ~data title message
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
end
open Errors
@ -131,35 +150,37 @@ open Errors
type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a
let parse (parser: 'a parser) source lexbuf =
let Lexer.{read ; close ; _} = Lexer.open_token_stream None in
let Lexer.{read; close; _} = Lexer.open_token_stream None in
let result =
try
ok (parser read lexbuf)
with
Scoping.Error (Scoping.Non_linear_pattern var) ->
fail @@ (non_linear_pattern var)
try ok (parser read lexbuf) with
Lexer.Error e ->
fail @@ lexer_error e
| Parser.Error ->
let start = Lexing.lexeme_start_p lexbuf in
let stop = Lexing.lexeme_end_p lexbuf in
fail @@ parser_error source start stop lexbuf
| Scoping.Error (Scoping.Non_linear_pattern var) ->
fail @@ non_linear_pattern var
| Scoping.Error (Duplicate_parameter name) ->
fail @@ (duplicate_parameter name)
fail @@ duplicate_parameter name
| Scoping.Error (Duplicate_variant name) ->
fail @@ (duplicate_variant name)
fail @@ duplicate_variant name
| Scoping.Error (Reserved_name name) ->
fail @@ (reserved_name name)
| SyntaxError.Error (Detached_attributes attrs) ->
fail @@ (detached_attributes attrs)
fail @@ reserved_name name
| Scoping.Error (Detached_attributes attrs) ->
fail @@ detached_attributes attrs
| 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)
| Lexer.Error e ->
fail @@ (lexer_error e)
fail @@ lexer_error e
| _ ->
let _ = Printexc.print_backtrace Pervasives.stdout in
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)
in
close ();
result
let stop = Lexing.lexeme_end_p lexbuf in
fail @@ unrecognized_error source start stop lexbuf
in close (); result
let parse_file (source: string) : AST.t result =
let pp_input =
@ -177,6 +198,17 @@ let parse_file (source: string) : AST.t result =
let lexbuf = Lexing.from_channel channel in
parse (Parser.contract) source lexbuf
let parse_file' (source: string) : AST.t result =
let module IO =
struct
let ext = "ligo"
let options = pre_options ~input:(Some source) ~expr:false
end in
let module Unit = PreUnit(IO) in
match Unit.parse Unit.parse_contract with
Ok ast -> ok ast
| Error error -> failwith "TODO" (* fail @@ parser_or_lexer_error error *)
let parse_string (s:string) : AST.t result =
let lexbuf = Lexing.from_string s in
parse (Parser.contract) "" lexbuf

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

@ -20,4 +20,6 @@ $HOME/git/ligo/vendors/ligo-utils/simple-utils/region.ml
../shared/LexerUnit.ml
../shared/ParserUnit.mli
../shared/ParserUnit.ml
../shared/Memo.mli
../shared/Memo.ml
Stubs/Simple_utils.ml

14
src/passes/1-parser/pascaligo/AST.ml
View File

@ -25,6 +25,7 @@ type 'a reg = 'a Region.reg
type keyword = Region.t
type kwd_and = Region.t
type kwd_attributes = Region.t
type kwd_begin = Region.t
type kwd_block = Region.t
type kwd_case = Region.t
@ -109,7 +110,7 @@ type field_name = string reg
type map_name = string reg
type set_name = string reg
type constr = string reg
type attribute = string reg
type attribute = string reg
(* Parentheses *)
@ -144,12 +145,12 @@ type t = {
and ast = t
and attributes = attribute list reg
and attributes = attribute ne_injection reg
and declaration =
TypeDecl of type_decl reg
TypeDecl of type_decl reg
| ConstDecl of const_decl reg
| FunDecl of fun_decl reg
| FunDecl of fun_decl reg
and const_decl = {
kwd_const : kwd_const;
@ -159,7 +160,7 @@ and const_decl = {
equal : equal;
init : expr;
terminator : semi option;
attributes : attributes;
attributes : attributes option
}
(* Type declarations *)
@ -217,7 +218,7 @@ and fun_decl = {
block_with : (block reg * kwd_with) option;
return : expr;
terminator : semi option;
attributes : attributes;
attributes : attributes option;
}
and parameters = (param_decl, semi) nsepseq par reg
@ -562,6 +563,7 @@ and field_assign = {
equal : equal;
field_expr : expr
}
and record = field_assign reg ne_injection
and projection = {

9
src/passes/1-parser/pascaligo/LexToken.mli
View File

@ -28,6 +28,11 @@ type lexeme = string
(* TOKENS *)
type attribute = {
header : string;
string : lexeme Region.reg
}
type t =
(* Literals *)
@ -38,6 +43,7 @@ type t =
| Mutez of (lexeme * Z.t) Region.reg
| Ident of lexeme Region.reg
| Constr of lexeme Region.reg
| Attr of attribute
(* Symbols *)
@ -151,8 +157,7 @@ val mk_kwd : lexeme -> Region.t -> (token, kwd_err) result
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)

24
src/passes/1-parser/pascaligo/LexToken.mll
View File

@ -26,6 +26,11 @@ let rollback buffer =
(* TOKENS *)
type attribute = {
header : string;
string : lexeme Region.reg
}
type t =
(* Literals *)
@ -33,9 +38,10 @@ type t =
| Bytes of (lexeme * Hex.t) Region.reg
| Int of (lexeme * Z.t) Region.reg
| Nat of (lexeme * Z.t) Region.reg
| Mutez of (lexeme * Z.t) Region.reg
| Mutez of (lexeme * Z.t) Region.reg
| Ident of lexeme Region.reg
| Constr of lexeme Region.reg
| Attr of attribute
(* Symbols *)
@ -144,6 +150,9 @@ let proj_token = function
| Constr Region.{region; value} ->
region, sprintf "Constr \"%s\"" value
| Attr {header; string={region; value}} ->
region, sprintf "Attr (\"%s\",\"%s\")" header value
(* Symbols *)
| SEMI region -> region, "SEMI"
@ -217,7 +226,7 @@ let proj_token = function
| C_None region -> region, "C_None"
| C_Some region -> region, "C_Some"
(* Virtual tokens *)
| EOF region -> region, "EOF"
@ -233,6 +242,7 @@ let to_lexeme = function
| Mutez i -> fst i.Region.value
| Ident id
| Constr id -> id.Region.value
| Attr {string; _} -> string.Region.value
(* Symbols *)
@ -312,6 +322,7 @@ let to_lexeme = function
| EOF _ -> ""
(* CONVERSIONS *)
let to_string token ?(offsets=true) mode =
let region, val_str = proj_token token in
@ -365,7 +376,7 @@ let keywords = [
let reserved =
let open SSet in
empty |> add "args"
empty |> add "arguments"
let constructors = [
(fun reg -> False reg);
@ -489,8 +500,6 @@ let eof region = EOF region
type sym_err = Invalid_symbol
type attr_err = Invalid_attribute
let mk_sym lexeme region =
match lexeme with
(* Lexemes in common with all concrete syntaxes *)
@ -539,10 +548,9 @@ let mk_constr lexeme region =
(* Attributes *)
let mk_attr _lexeme _region =
Error Invalid_attribute
type attr_err = Invalid_attribute
let mk_attr2 _lexeme _region =
let mk_attr _header _string _region =
Error Invalid_attribute
(* Predicates *)

5
src/passes/1-parser/pascaligo/LexerMain.ml
View File

@ -7,3 +7,8 @@ module IO =
end
module M = LexerUnit.Make (IO) (Lexer.Make (LexToken))
let () =
match M.trace () with
Stdlib.Ok _ -> ()
| Error msg -> Printf.eprintf "\027[31m%s\027[0m%!" msg

1
src/passes/1-parser/pascaligo/ParToken.mly
View File

@ -12,6 +12,7 @@
%token <(LexToken.lexeme * Z.t) Region.reg> Mutez "<mutez>"
%token <LexToken.lexeme Region.reg> Ident "<ident>"
%token <LexToken.lexeme Region.reg> Constr "<constr>"
%token <LexToken.attribute Region.reg> Attr "<attr>"
(* Symbols *)

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

@ -5,39 +5,40 @@
open Region
open AST
type statement_attributes_mixed =
(*
type statement_attributes_mixed =
PInstr of instruction
| PData of data_decl
| PAttributes of attributes
| PAttr of attributes
let attributes_to_statement (statement, statements) =
if (List.length statements = 0) then
match statement with
| PInstr i -> Instr i, []
| PData d -> Data d, []
| PAttributes a ->
let open! SyntaxError in
raise (Error (Detached_attributes a))
else (
match statements with
[] ->
(match statement with
| PInstr i -> Instr i, []
| PData d -> Data d, []
| PAttr a ->
raise (Scoping.Error (Scoping.Detached_attributes a)))
| _ -> (
let statements = (Region.ghost, statement) :: statements in
let rec inner result = function
| (t, PData (LocalConst const)) :: (_, PAttributes a) :: rest ->
| (t, PData (LocalConst const)) :: (_, PAttr a) :: rest ->
inner (result @ [(t, Data (LocalConst {const with value = {const.value with attributes = a}}))]) rest
| (t, PData (LocalFun func)) :: (_, PAttributes a) :: rest ->
inner (result @ [(t, Data (LocalFun {func with value = {func.value with attributes = a}}))]) rest
| (t, PData (LocalFun func)) :: (_, PAttr a) :: rest ->
inner (result @ [(t, Data (LocalFun {func with value = {func.value with attributes = a}}))]) rest
| (t, PData d) :: rest ->
inner (result @ [(t, Data d)]) rest
| (t, PInstr i) :: rest ->
inner (result @ [(t, Instr i)]) rest
| (_, PAttributes _) :: rest ->
| (_, PAttr _) :: rest ->
inner result rest
| [] ->
| [] ->
result
in
in
let result = inner [] statements in
(snd (List.hd result), List.tl result)
)
*)
(* END HEADER *)
%}
@ -145,7 +146,7 @@ contract:
declaration:
type_decl { TypeDecl $1 }
| const_decl { ConstDecl $1 }
| fun_decl { FunDecl $1 }
| fun_decl { FunDecl $1 }
(* Type declarations *)
@ -258,7 +259,7 @@ field_decl:
and value = {field_name=$1; colon=$2; field_type=$3}
in {region; value} }
fun_expr:
"function" parameters ":" type_expr "is" expr {
let stop = expr_to_region $6 in
@ -290,7 +291,7 @@ open_fun_decl:
block_with = Some ($7, $8);
return = $9;
terminator = None;
attributes = {value = []; region = Region.ghost}}
attributes = None}
in {region; value} }
| "function" fun_name parameters ":" type_expr "is" expr {
Scoping.check_reserved_name $2;
@ -305,14 +306,16 @@ open_fun_decl:
block_with = None;
return = $7;
terminator = None;
attributes = {value = []; region = Region.ghost}}
attributes = None}
in {region; value} }
fun_decl:
open_fun_decl semi_attributes {
let attributes, terminator = $2 in
{$1 with value = {$1.value with terminator = terminator; attributes = attributes}}
}
open_fun_decl maybe_attributes? {
match $2 with
None -> $1
| Some (terminator, attributes) ->
let value = {$1.value with terminator; attributes}
in {$1 with value} }
parameters:
par(nsepseq(param_decl,";")) {
@ -350,7 +353,7 @@ block:
let statements, terminator = $2 in
let region = cover $1 $3
and value = {opening = Begin $1;
statements = attributes_to_statement statements;
statements (*= attributes_to_statement statements*);
terminator;
closing = End $3}
in {region; value}
@ -359,15 +362,15 @@ block:
let statements, terminator = $3 in
let region = cover $1 $4
and value = {opening = Block ($1,$2);
statements = attributes_to_statement statements;
statements (*= attributes_to_statement statements*);
terminator;
closing = Block $4}
in {region; value} }
statement:
instruction { PInstr $1 }
| open_data_decl { PData $1 }
| attributes { PAttributes $1 }
instruction { (*P*)Instr $1 }
| open_data_decl { (*P*)Data $1 }
(*| attributes { PAttr $1 }*)
open_data_decl:
open_const_decl { LocalConst $1 }
@ -385,10 +388,9 @@ open_const_decl:
equal;
init;
terminator = None;
attributes = {value = []; region = Region.ghost}}
attributes = None}
in {region; value} }
open_var_decl:
"var" unqualified_decl(":=") {
let name, colon, var_type, assign, init, stop = $2 in
@ -399,8 +401,7 @@ open_var_decl:
var_type;
assign;
init;
terminator = None;
}
terminator=None}
in {region; value} }
unqualified_decl(OP):
@ -409,23 +410,20 @@ unqualified_decl(OP):
let region = expr_to_region $5
in $1, $2, $3, $4, $5, region }
attributes:
"attributes" "[" nsepseq(String,";") "]" {
let region = cover $1 $4 in
let value = (Utils.nsepseq_to_list $3) in
{region; value}
}
attributes:
ne_injection("attributes","<string>") { $1 }
semi_attributes:
/* empty */ { {value = []; region = Region.ghost}, None }
| ";" { {value = []; region = Region.ghost}, Some $1 }
| ";" attributes ";" { $2, Some $1 }
maybe_attributes:
";" { Some $1, None }
| ";" attributes ";" { Some $1, Some $2 }
const_decl:
open_const_decl semi_attributes {
let attributes, terminator = $2 in
{$1 with value = {$1.value with terminator = terminator; attributes = attributes }}
}
open_const_decl maybe_attributes? {
match $2 with
None -> $1
| Some (terminator, attributes) ->
let value = {$1.value with terminator; attributes}
in {$1 with value} }
instruction:
conditional { Cond $1 }
@ -589,7 +587,7 @@ clause_block:
let statements, terminator = $2 in
let region = cover $1 $3 in
let value = {lbrace = $1;
inside = attributes_to_statement statements, terminator;
inside = (*attributes_to_statement*) statements, terminator;
rbrace = $3} in
ShortBlock {value; region} }

54
src/passes/1-parser/pascaligo/ParserLog.ml
View File

@ -114,12 +114,10 @@ let rec print_tokens state ast =
Utils.nseq_iter (print_decl state) decl;
print_token state eof "EOF"
and print_attributes state attributes =
let attributes = List.fold_left (fun all a -> all ^ a.value ^ ";") "" attributes.value in
let line =
sprintf "attributes[%s]"
attributes
in Buffer.add_string state#buffer line
and print_attributes state = function
None -> ()
| Some attr ->
print_ne_injection state "attributes" print_string attr
and print_decl state = function
TypeDecl decl -> print_type_decl state decl
@ -607,7 +605,7 @@ and print_field_assign state {value; _} =
print_token state equal "=";
print_expr state field_expr
and print_update_expr state {value; _} =
and print_update_expr state {value; _} =
let {record; kwd_with; updates} = value in
print_path state record;
print_token state kwd_with "with";
@ -850,19 +848,23 @@ and pp_declaration state = function
pp_fun_decl state value
and pp_fun_decl state decl =
let arity =
match decl.attributes with
None -> 5
| Some _ -> 6 in
let () =
let state = state#pad 5 0 in
let state = state#pad arity 0 in
pp_ident state decl.fun_name in
let () =
let state = state#pad 5 1 in
let state = state#pad arity 1 in
pp_node state "<parameters>";
pp_parameters state decl.param in
let () =
let state = state#pad 5 2 in
let state = state#pad arity 2 in
pp_node state "<return type>";
pp_type_expr (state#pad 1 0) decl.ret_type in
let () =
let state = state#pad 5 3 in
let state = state#pad arity 3 in
pp_node state "<body>";
let statements =
match decl.block_with with
@ -870,15 +872,35 @@ and pp_fun_decl state decl =
| None -> Instr (Skip Region.ghost), [] in
pp_statements state statements in
let () =
let state = state#pad 5 4 in
let state = state#pad arity 4 in
pp_node state "<return>";
pp_expr (state#pad 1 0) decl.return
pp_expr (state#pad 1 0) decl.return in
let () =
match decl.attributes with
None -> ()
| Some attr ->
let state = state#pad arity 5 in
pp_node state "<attributes>";
pp_attributes (state#pad 1 0) attr
in ()
and pp_attributes state {value; _} =
pp_ne_injection pp_string state value
and pp_const_decl state decl =
pp_ident (state#pad 3 0) decl.name;
pp_type_expr (state#pad 3 1) decl.const_type;
pp_expr (state#pad 3 2) decl.init
let arity =
match decl.attributes with
None -> 3
| Some _ -> 4 in
pp_ident (state#pad arity 0) decl.name;
pp_type_expr (state#pad arity 1) decl.const_type;
pp_expr (state#pad arity 2) decl.init;
match decl.attributes with
None -> ()
| Some attr ->
let state = state#pad arity 3 in
pp_node state "<attributes>";
pp_attributes (state#pad 1 0) attr
and pp_type_expr state = function
TProd cartesian ->

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

@ -6,6 +6,7 @@ type t =
| Duplicate_variant of AST.variable
| Non_linear_pattern of AST.variable
| Duplicate_field of AST.variable
| Detached_attributes of AST.attributes
type error = t

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

@ -47,9 +47,9 @@ let help language extension () =
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)";
print " -t, --tokens Print tokens (lexer)";
print " -u, --units Print tokens and markup (lexer)";
print " -t, --tokens Print tokens";
print " -u, --units Print lexical units";
print " -c, --copy Print lexemes and markup";
print " -q, --quiet No output, except errors (default)";
print " --columns Columns for source locations";
print " --bytes Bytes for source locations";

3
src/passes/1-parser/shared/Lexer.mli
View File

@ -77,8 +77,7 @@ module type TOKEN =
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)

81
src/passes/1-parser/shared/Lexer.mll
View File

@ -119,8 +119,7 @@ module type TOKEN =
val mk_string : lexeme -> Region.t -> token
val mk_bytes : lexeme -> Region.t -> token
val mk_constr : lexeme -> Region.t -> token
val mk_attr : lexeme -> Region.t -> (token, attr_err) result
val mk_attr2 : lexeme -> Region.t -> (token, attr_err) result
val mk_attr : string -> lexeme -> Region.t -> (token, attr_err) result
val eof : Region.t -> token
(* Predicates *)
@ -178,8 +177,9 @@ module type S =
exception Error of error Region.reg
val format_error : ?offsets:bool -> [`Byte | `Point] ->
error Region.reg -> file:bool -> string
val format_error :
?offsets:bool -> [`Byte | `Point] ->
error Region.reg -> file:bool -> string
end
(* The functorised interface
@ -436,15 +436,15 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
Hint: Check the LIGO syntax you use.\n"
| Invalid_natural ->
"Invalid natural."
| Invalid_attribute ->
| Invalid_attribute ->
"Invalid attribute."
exception Error of error Region.reg
let format_error ?(offsets=true) mode Region.{region; value} ~file =
let msg = error_to_string value in
let reg = region#to_string ~file ~offsets mode in
sprintf "\027[31mLexical error %s:\n%s\027[0m%!" reg msg
let msg = error_to_string value
and reg = region#to_string ~file ~offsets mode
in sprintf "Lexical error %s:\n%s" reg msg
let fail region value = raise (Error Region.{region; value})
@ -506,7 +506,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
let num = Z.of_string (integral ^ fractional)
and den = Z.of_string ("1" ^ String.make (len-index-1) '0')
and million = Q.of_string "1000000" in
let mutez = Q.make num den |> Q.mul million in
let mutez = Q.make num den |> Q.mul million in
let should_be_1 = Q.den mutez in
if Z.equal Z.one should_be_1 then Some (Q.num mutez) else None
| exception Not_found -> assert false
@ -531,22 +531,14 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
Ok token -> token, state
| Error Token.Reserved_name -> fail region (Reserved_name lexeme)
let mk_attr state buffer attr =
let mk_attr header attr state buffer =
let region, _, state = sync state buffer in
match Token.mk_attr attr region with
Ok token ->
token, state
| Error Token.Invalid_attribute ->
fail region Invalid_attribute
match Token.mk_attr header attr region with
Ok token ->
token, state
| Error Token.Invalid_attribute ->
fail region Invalid_attribute
let mk_attr2 state buffer attr =
let region, _, state = sync state buffer in
match Token.mk_attr2 attr region with
Ok token ->
token, state
| Error Token.Invalid_attribute ->
fail region Invalid_attribute
let mk_constr state buffer =
let region, lexeme, state = sync state buffer
in Token.mk_constr lexeme region, state
@ -560,7 +552,7 @@ module Make (Token: TOKEN) : (S with module Token = Token) =
let mk_eof state buffer =
let region, _, state = sync state buffer
in Token.eof region, state
(* END HEADER *)
}
@ -580,6 +572,7 @@ let capital = ['A'-'Z']
let letter = small | capital
let ident = small (letter | '_' | digit)*
let constr = capital (letter | '_' | digit)*
let attr = ident | constr
let hexa_digit = digit | ['A'-'F']
let byte = hexa_digit hexa_digit
let byte_seq = byte | byte (byte | '_')* byte
@ -587,8 +580,8 @@ let bytes = "0x" (byte_seq? as seq)
let esc = "\\n" | "\\\"" | "\\\\" | "\\b"
| "\\r" | "\\t" | "\\x" byte
let pascaligo_sym = "=/=" | '#' | ":="
let cameligo_sym = "<>" | "::" | "||" | "&&" | "[@"
let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&" | "[@"
let cameligo_sym = "<>" | "::" | "||" | "&&"
let reasonligo_sym = '!' | "=>" | "!=" | "==" | "++" | "..." | "||" | "&&"
let symbol =
';' | ',' | '(' | ')'| '[' | ']' | '{' | '}'
@ -614,21 +607,24 @@ rule init state = parse
| _ { rollback lexbuf; scan state lexbuf }
and scan state = parse
nl { scan (push_newline state lexbuf) lexbuf }
| ' '+ { scan (push_space state lexbuf) lexbuf }
| '\t'+ { scan (push_tabs state lexbuf) lexbuf }
| ident { mk_ident state lexbuf |> enqueue }
| constr { mk_constr state lexbuf |> enqueue }
| bytes { (mk_bytes seq) state lexbuf |> enqueue }
| natural 'n' { mk_nat state lexbuf |> enqueue }
| natural "mutez" { mk_mutez state lexbuf |> enqueue }
| natural "tz" { mk_tz state lexbuf |> enqueue }
| decimal "tz" { mk_tz_decimal state lexbuf |> enqueue }
| natural { mk_int state lexbuf |> enqueue }
| symbol { mk_sym state lexbuf |> enqueue }
| eof { mk_eof state lexbuf |> enqueue }
| "[@" (ident|constr as attr) "]" { mk_attr state lexbuf attr |> enqueue }
| "[@@" (ident|constr as attr) "]" { mk_attr2 state lexbuf attr |> enqueue }
nl { scan (push_newline state lexbuf) lexbuf }
| ' '+ { scan (push_space state lexbuf) lexbuf }
| '\t'+ { scan (push_tabs state lexbuf) lexbuf }
| ident { mk_ident state lexbuf |> enqueue }
| constr { mk_constr state lexbuf |> enqueue }
| bytes { mk_bytes seq state lexbuf |> enqueue }
| natural 'n' { mk_nat state lexbuf |> enqueue }
| natural "mutez" { mk_mutez state lexbuf |> enqueue }
| natural "tz"
| natural "tez" { mk_tz state lexbuf |> enqueue }
| decimal "tz"
| decimal "tez" { mk_tz_decimal state lexbuf |> enqueue }
| natural { mk_int state lexbuf |> enqueue }
| symbol { mk_sym state lexbuf |> enqueue }
| eof { mk_eof state lexbuf |> enqueue }
| "[@" (attr as a) "]" { mk_attr "[@" a state lexbuf |> enqueue }
| "[@@" (attr as a) "]" { mk_attr "[@@" a state lexbuf |> enqueue }
| '"' { let opening, _, state = sync state lexbuf in
let thread = {opening; len=1; acc=['"']} in
scan_string thread state lexbuf |> mk_string |> enqueue }
@ -677,8 +673,7 @@ and scan state = parse
and file = Filename.basename file in
let pos = state.pos#set ~file ~line ~offset:0 in
let state = {state with pos} in
scan state lexbuf
}
scan state lexbuf }
(* Some special errors

33
src/passes/1-parser/shared/LexerLog.ml
View File

@ -1,7 +1,5 @@
(** Embedding the LIGO lexer in a debug module *)
let sprintf = Printf.sprintf
module type S =
sig
module Lexer : Lexer.S
@ -15,12 +13,12 @@ module type S =
val trace :
?offsets:bool -> [`Byte | `Point] ->
file_path option -> EvalOpt.command -> unit
file_path option -> EvalOpt.command ->
(unit, string) Stdlib.result
end
module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) =
struct
module Lexer = Lexer
module Token = Lexer.Token
@ -49,28 +47,29 @@ module Make (Lexer: Lexer.S) : (S with module Lexer = Lexer) =
type file_path = string
let trace ?(offsets=true) mode file_path_opt command : unit =
let trace ?(offsets=true) mode file_path_opt command :
(unit, string) Stdlib.result =
try
let Lexer.{read; buffer; close; _} =
Lexer.open_token_stream file_path_opt
and cout = stdout in
let log = output_token ~offsets mode command cout
and close_all () = close (); close_out cout in
Lexer.open_token_stream file_path_opt in
let log = output_token ~offsets mode command stdout
and close_all () = close (); close_out stdout in
let rec iter () =
match read ~log buffer with
token ->
if Token.is_eof token then close_all ()
if Token.is_eof token
then Stdlib.Ok ()
else iter ()
| exception Lexer.Error e ->
| exception Lexer.Error error ->
let file =
match file_path_opt with
None | Some "-" -> false
| Some _ -> true in
| Some _ -> true in
let msg =
Lexer.format_error ~offsets mode e ~file
in prerr_string msg;
close_all ()
in iter ()
with Sys_error msg -> Utils.highlight (sprintf "%s\n" msg)
Lexer.format_error ~offsets mode ~file error
in Stdlib.Error msg in
let result = iter ()
in (close_all (); result)
with Sys_error msg -> Stdlib.Error msg
end

3
src/passes/1-parser/shared/LexerLog.mli
View File

@ -11,7 +11,8 @@ module type S =
val trace :
?offsets:bool -> [`Byte | `Point] ->
file_path option -> EvalOpt.command -> unit
file_path option -> EvalOpt.command ->
(unit, string) Stdlib.result
end
module Make (Lexer: Lexer.S) : S with module Lexer = Lexer

83
src/passes/1-parser/shared/LexerUnit.ml
View File

@ -1,21 +1,20 @@
(* Functor to build a standalone LIGO lexer *)
module type S =
module type IO =
sig
val ext : string (* LIGO file extension *)
val options : EvalOpt.options (* CLI options *)
end
module Make (IO: S) (Lexer: Lexer.S) =
module Make (IO: IO) (Lexer: Lexer.S) =
struct
open Printf
module SSet = Utils.String.Set
(* Error printing and exception tracing *)
let () = Printexc.record_backtrace true
let external_ text =
Utils.highlight (sprintf "External error: %s" text); exit 1
(* Preprocessing the input source and opening the input channels *)
(* Path for CPP inclusions (#include) *)
@ -29,7 +28,7 @@ module Make (IO: S) (Lexer: Lexer.S) =
let prefix =
match IO.options#input with
None | Some "-" -> "temp"
| Some file -> Filename.(file |> basename |> remove_extension)
| Some file -> Filename.(file |> basename |> remove_extension)
let suffix = ".pp" ^ IO.ext
@ -42,24 +41,68 @@ module Make (IO: S) (Lexer: Lexer.S) =
let cpp_cmd =
match IO.options#input with
None | Some "-" ->
sprintf "cpp -traditional-cpp%s - > %s"
lib_path pp_input
| Some file ->
sprintf "cpp -traditional-cpp%s %s > %s"
lib_path file pp_input
let () =
if Utils.String.Set.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)
sprintf "cpp -traditional-cpp%s - > %s"
lib_path pp_input
| Some file ->
sprintf "cpp -traditional-cpp%s %s > %s"
lib_path file pp_input
(* Running the lexer on the input file *)
let scan () : (Lexer.token list, string) Stdlib.result =
(* Preprocessing the input *)
if SSet.mem "cpp" IO.options#verbose
then eprintf "%s\n%!" cpp_cmd
else ();
if Sys.command cpp_cmd <> 0 then
let msg =
sprintf "External error: the command \"%s\" failed." cpp_cmd
in Stdlib.Error msg
else
try
let Lexer.{read; buffer; close; _} =
Lexer.open_token_stream (Some pp_input) in
let close_all () = close (); close_out stdout in
let rec read_tokens tokens =
match read ~log:(fun _ _ -> ()) buffer with
token ->
if Lexer.Token.is_eof token
then Stdlib.Ok (List.rev tokens)
else read_tokens (token::tokens)
| exception Lexer.Error error ->
let file =
match IO.options#input with
None | Some "-" -> false
| Some _ -> true in
let msg =
Lexer.format_error ~offsets:IO.options#offsets
IO.options#mode ~file error
in Stdlib.Error msg in
let result = read_tokens []
in close_all (); result
with Sys_error msg -> close_out stdout; Stdlib.Error msg
(* Tracing the lexing (effectful) *)
module Log = LexerLog.Make (Lexer)
let () = Log.trace ~offsets:IO.options#offsets
IO.options#mode (Some pp_input)
IO.options#cmd
let trace () : (unit, string) Stdlib.result =
(* Preprocessing the input *)
if SSet.mem "cpp" IO.options#verbose
then eprintf "%s\n%!" cpp_cmd
else ();
if Sys.command cpp_cmd <> 0 then
let msg =
sprintf "External error: the command \"%s\" failed." cpp_cmd
in Stdlib.Error msg
else
Log.trace ~offsets:IO.options#offsets
IO.options#mode
(Some pp_input)
IO.options#cmd
end

13
src/passes/1-parser/shared/LexerUnit.mli Normal file
View File

@ -0,0 +1,13 @@
(* Functor to build a standalone LIGO lexer *)
module type IO =
sig
val ext : string (* LIGO file extension *)
val options : EvalOpt.options (* CLI options *)
end
module Make (IO: IO) (Lexer: Lexer.S) :
sig
val scan : unit -> (Lexer.token list, string) Stdlib.result
val trace : unit -> (unit, string) Stdlib.result
end

163
src/passes/1-parser/shared/Memo.ml Normal file
View File

@ -0,0 +1,163 @@
module Region = Simple_utils.Region
type macro = {
origin : Region.t; (* Not ghost *)
current : Region.t (* Maybe ghost *)
}
type location =
Loc of Region.t (* Not ghost *)
| Link of macro
(* Regions must not be ghosts and strings must not be empty. *)
type valid_lexeme = string Region.reg (* Not ghost, not empty. *)
type invalid_lexeme = string Region.reg (* Not ghost, empty if EOF. *)
type phase =
Lexer
| Parser of valid_lexeme option * invalid_lexeme
| Scoping
type error = <
location : location;
message : string; (* Sentence ending with a period *)
hint : string; (* Suggestion to solve the issue *)
help : string (* Off-program help *)
>
type invalid_error = Ghost_region
let check_loc = function
Loc reg ->
if reg#is_ghost then
Stdlib.Error Ghost_region
else Ok ()
| Link {origin; _} ->
if origin#is_ghost then
Stdlib.Error Ghost_region
else Ok ()
let make_error ~location ~message ~hint ~help =
match check_loc location with
Stdlib.Ok () ->
Ok (object
method location = location
method message = message
method hint = hint
method help = help
end)
| Error _ as e -> e
type warning = <
location : location;
message : string; (* Sentence ending with a period *)
hint : string; (* Idem *)
>
type invalid_warning = invalid_error
let make_warning ~location ~message ~hint =
match check_loc location with
Stdlib.Ok () ->
Ok (object
method location = location
method message = message
method hint = hint
method help = help
end)
| Error _ as e -> e
type kind =
Error of error (* Failure of an external invariant *)
| Internal of string (* Failure of an internal invariant *)
| External of string (* Failure of an external process *)
| Warning of warning
| Info of (unit -> string) (* Log *)
type entry = <
phase : phase;
kind : kind
>
type invalid_entry =
Ghost_lexeme
| Empty_lexeme
let check_phase = function
Parser (Some valid_lexeme, invalid_lexeme) ->
let open Region in
if valid_lexeme.region#is_ghost
|| invalid_lexeme.region#is_ghost
then Stdlib.Error Ghost_lexeme
else if valid_lexeme.value = ""
then Stdlib.Error Empty_lexeme
else Ok ()
| Parser (None, invalid_lexeme) ->
if invalid_lexeme.region#is_ghost
then Stdlib.Error Ghost_lexeme
else Ok ()
| Lexer
| Scoping -> Ok ()
let make_entry ~phase ~kind =
match check_phase phase with
Stdlib.Error _ as e -> e
| Ok () -> Ok (object
method phase = phase
method kind = kind
end)
type memo = <
mode : [`Byte | `Point]; (* Bytes vs UTF-8 *)
offsets : bool; (* [true] for horizontal offsets *)
log : entry FQueue.t
>
type t = memo
let empty_memo ~mode ~offsets : memo =
object
method mode = mode
method offsets = offsets
method log = FQueue.empty
method enqueue entry = {< log = FQueue.enq entry log >}
method dequeue =
match FQueue.deq log with
None -> None
| Some (log, entry) -> Some ({< log=log >}, entry)
end
let sprintf = Printf.sprintf
let string_of_entry ~(file:bool) entry : string =
let reg = entry#region#to_string
~file
~offsets:entry#offsets
error#mode in
let string =
match error#phase with
Parser (None, invalid_lexeme) ->
(match invalid_lexeme.Region.value with
"" -> sprintf "Parse error %s" reg (* EOF *)
| lexeme -> sprintf "Parse error %s, before \"%s\""
reg lexeme)
| Parser (Some valid_lexeme, invalid_lexeme) ->
let string =
sprintf "Parse error %s, after \"%s\""
reg valid_lexeme.Region.value in
(match invalid_lexeme.Region.value with
"" -> string (* EOF *)
| lexeme -> sprintf "%s and before \"%s\"" string lexeme)
| Lexer ->
sprintf "Lexical error %s" reg
| Scoping ->
sprintf "Scoping error %s" reg in
let string =
string
^ (if error#message = "" then "."
else ":\n" ^ error#message) ^ "\n" in
let string =
string ^ (if error#hint = "" then ""
else sprintf "Hint: %s\n" error#hint)
in string

120
src/passes/1-parser/shared/Memo.mli Normal file
View File

@ -0,0 +1,120 @@
(* This module defines compilation memos. *)
(* Locations *)
module Region = Simple_utils.Region
type macro = private <
origin : Region.t; (* Not ghost *)
current : Region.t (* Maybe ghost *)
>
type location = private
Loc of Region.t (* Not ghost *)
| Link of macro
type invalid_loc = Ghost_region
val make_loc :
Region.t -> (location, invalid_loc) Stdlib.result
val make_link :
origin:Region.t ->
current:Region.t ->
(location, invalid_loc) Stdlib.result
type 'a located = <
value : 'a;
location : location
>
val make_located : value:'a -> location:location -> 'a located
(* Lexemes *)
type lexeme = string location (* Not ghost, empty => EOF *)
type window = <
valid_lexeme : lexeme option;
invalid_lexeme : lexeme
>
val make_window : ?valid:lexeme -> invalid:lexeme -> window
(* Compilation phases *)
type phase =
Lexer
| Parser of window
| Scoping
(* Messages *)
type message = private string
type invalid_message = Empty_message
val make_message : string -> (message, invalid_error) Stdlib.result
val string_of_message : message -> string
(* Errors *)
type error = <
location : location;
message : message; (* Non-empty string (ending with a period) *)
hint : string; (* Suggestion to solve the issue (may be empty) *)
help : string (* Off-program help (may be empty) *)
>
val make_error :
location:location ->
message:message ->
hint:string ->
help:string ->
error
(* Warnings *)
type warning = <
location : location;
message : message; (* Non-empty string (ending with a period) *)
hint : string; (* May empty *)
>
val make_warning :
location:location ->
message:message ->
hint:string ->
warning
(* Kinds of entries *)
type kind =
Error of error (* Failure of an external invariant *)
| Internal of message (* Failure of an internal invariant (non-empty) *)
| External of message (* Failure of an external process (non-empty) *)
| Warning of warning
| Info of (unit -> message) (* Log (not-empty) *)
type entry = private <
phase : phase;
kind : kind
>
val make_entry : phase:phase -> kind:kind -> entry
val string_of_entry : file:bool -> entry -> string
(* Memos *)
type memo = <
mode : [`Byte | `Point]; (* Bytes vs UTF-8 *)
offsets : bool; (* [true] for horizontal offsets *)
log : entry FQueue.t;
enqueue : entry -> memo;
dequeue : (memo * entry) option
>
type t = memo
val empty_memo : mode:[`Byte | `Point] -> offsets:bool -> memo

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

@ -90,11 +90,16 @@ module Make (Lexer: Lexer.S)
module Incr = Parser.Incremental
let incr_contract Lexer.{read; buffer; get_win; close; _} : Parser.ast =
let incr_contract memo Lexer.{read; buffer; get_win; close; _} =
let supplier = I.lexer_lexbuf_to_supplier read buffer
and failure = failure get_win in
let parser = Incr.contract buffer.Lexing.lex_curr_p in
let ast = I.loop_handle success failure supplier parser
let ast =
try I.loop_handle success failure supplier parser with
Point (message, valid_opt, invalid) ->
let error = Memo. (* TODO *)
in Stdlib.Error ()
in close (); ast
let mono_contract = Parser.contract
@ -117,22 +122,17 @@ module Make (Lexer: Lexer.S)
let trailer =
match valid_opt with
None ->
if Lexer.Token.is_eof invalid then ""
else let invalid_lexeme = Lexer.Token.to_lexeme invalid in
Printf.sprintf ", before \"%s\"" invalid_lexeme
if Lexer.Token.is_eof invalid then ""
else let invalid_lexeme = Lexer.Token.to_lexeme invalid in
Printf.sprintf ", before \"%s\"" invalid_lexeme
| Some valid ->
let valid_lexeme = Lexer.Token.to_lexeme valid in
let s = Printf.sprintf ", after \"%s\"" valid_lexeme in
if Lexer.Token.is_eof invalid then s
else
let invalid_lexeme = Lexer.Token.to_lexeme invalid in
Printf.sprintf "%s and before \"%s\"" s invalid_lexeme in
let valid_lexeme = Lexer.Token.to_lexeme valid in
let s = Printf.sprintf ", after \"%s\"" valid_lexeme in
if Lexer.Token.is_eof invalid then s
else
let invalid_lexeme = Lexer.Token.to_lexeme invalid in
Printf.sprintf "%s and before \"%s\"" s invalid_lexeme in
let header = header ^ trailer in
header ^ (if msg = "" then ".\n" else ":\n" ^ msg)
let short_error ?(offsets=true) mode msg (invalid_region: Region.t) =
let () = assert (not (invalid_region#is_ghost)) in
let header =
"Parse error " ^ invalid_region#to_string ~offsets mode in
header ^ (if msg = "" then ".\n" else ":\n" ^ msg)
end

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

@ -2,6 +2,9 @@
module Region = Simple_utils.Region
(* The signature generated by Menhir with additional type definitions
for [ast] and [expr]. *)
module type PARSER =
sig
(* The type of tokens. *)
@ -44,30 +47,24 @@ module Make (Lexer: Lexer.S)
(Parser: PARSER with type token = Lexer.Token.token)
(ParErr: sig val message : int -> string end) :
sig
(* Monolithic and incremental APIs of Menhir for parsing *)
(* The monolithic API of Menhir with memos *)
val mono_contract :
(Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> Parser.ast
val incr_contract :
Lexer.instance -> Parser.ast
(Lexing.lexbuf -> Lexer.token) ->
Lexing.lexbuf ->
(Parser.ast, string) Stdlib.result
val mono_expr :
(Lexing.lexbuf -> Lexer.token) -> Lexing.lexbuf -> Parser.expr
(Lexing.lexbuf -> Lexer.token) ->
Lexing.lexbuf ->
(Parser.expr, string) Stdlib.result
(* Incremental API of Menhir with memos *)
val incr_contract :
Lexer.instance -> (Parser.ast, string) Stdlib.result
val incr_expr :
Lexer.instance -> Parser.expr
(* Error handling *)
type message = string
type valid = Parser.token
type invalid = Parser.token
type error = message * valid option * invalid
exception Point of error
val format_error :
?offsets:bool -> [`Byte | `Point] -> error -> string
val short_error :
?offsets:bool -> [`Byte | `Point] -> message -> Region.t -> string
Lexer.instance ->
(Parser.expr, string) Stdlib.result
end

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

@ -88,7 +88,6 @@ module Make (Lexer: Lexer.S)
module Front = ParserAPI.Make (Lexer)(Parser)(ParErr)
let format_error = Front.format_error
let short_error = Front.short_error
(* Parsing an expression *)
@ -96,25 +95,28 @@ module Make (Lexer: Lexer.S)
(AST.expr, string) Stdlib.result =
let close_all () =
lexer_inst.Lexer.close (); close_out stdout in
let lexbuf = lexer_inst.Lexer.buffer in
let expr =
if IO.options#mono then
Front.mono_expr tokeniser lexer_inst.Lexer.buffer
else
Front.incr_expr lexer_inst in
try
if IO.options#mono then
Front.mono_expr tokeniser lexbuf
else
Front.incr_expr lexer_inst
with exn -> close_all (); raise exn 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
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
if SSet.mem "ast" IO.options#verbose then
begin
Buffer.clear output;
ParserLog.pp_expr state expr;
Buffer.output_buffer stdout output
end
in close_all (); Ok expr
(* Parsing a contract *)
@ -123,27 +125,28 @@ module Make (Lexer: Lexer.S)
: (AST.t, string) Stdlib.result =
let close_all () =
lexer_inst.Lexer.close (); close_out stdout in
let lexbuf = lexer_inst.Lexer.buffer in
let ast =
try
if IO.options#mono then
Front.mono_contract tokeniser lexer_inst.Lexer.buffer
Front.mono_contract tokeniser lexbuf
else
Front.incr_contract lexer_inst
with exn -> close_all (); raise exn in
let () =
if SSet.mem "ast" IO.options#verbose
then begin
Buffer.clear output;
ParserLog.pp_ast state ast;
Buffer.output_buffer stdout output
end in
if SSet.mem "ast-tokens" IO.options#verbose then
begin
Buffer.clear output;
ParserLog.print_tokens state ast;
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 output
end
if SSet.mem "ast" IO.options#verbose then
begin
Buffer.clear output;
ParserLog.pp_ast state ast;
Buffer.output_buffer stdout output
end
in close_all (); Ok ast
(* Wrapper for the parsers above *)
@ -157,7 +160,7 @@ module Make (Lexer: Lexer.S)
if Sys.command cpp_cmd <> 0 then
let msg =
sprintf "External error: the command \"%s\" failed." cpp_cmd
sprintf "External error: \"%s\" failed." cpp_cmd
in Stdlib.Error msg
else
(* Instantiating the lexer *)

3
src/passes/1-parser/shared/ParserUnit.mli
View File

@ -46,9 +46,6 @@ module Make (Lexer: Lexer.S)
val format_error :
?offsets:bool -> [`Byte | `Point] -> error -> string
val short_error :
?offsets:bool -> [`Byte | `Point] -> message -> Region.t -> string
(* Parsers *)
val parse :

58
vendors/ligo-utils/simple-utils/pos.ml vendored
View File

@ -23,9 +23,10 @@ type t = <
is_ghost : bool;
to_string : ?offsets:bool -> [`Byte | `Point] -> string;
compact : ?offsets:bool -> [`Byte | `Point] -> string;
anonymous : ?offsets:bool -> [`Byte | `Point] -> string
to_string :
?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
compact :
?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
>
type pos = t
@ -55,14 +56,15 @@ let make ~byte ~point_num ~point_bol =
method set_offset offset =
{< byte = Lexing.{byte with pos_cnum = byte.pos_bol + offset} >}
method set ~file ~line ~offset =
let pos = self#set_file file in
method set ?file ~line ~offset =
let pos =
match file with
None -> self
| Some name -> self#set_file name in
let pos = pos#set_line line in
let pos = pos#set_offset offset
in pos
(* The string must not contain '\n'. See [new_line]. *)
method shift_bytes len =
{< byte = Lexing.{byte with pos_cnum = byte.pos_cnum + len};
point_num = point_num + len >}
@ -77,11 +79,13 @@ let make ~byte ~point_num ~point_bol =
pos_bol = byte.pos_cnum};
point_bol = point_num >}
(* The string must not contain '\n'. See [add_line]. *)
method new_line string =
let len = String.length string
in (self#shift_bytes len)#add_nl
method is_ghost = byte = Lexing.dummy_pos
method is_ghost = (byte = Lexing.dummy_pos)
method file = byte.Lexing.pos_fname
@ -99,24 +103,30 @@ let make ~byte ~point_num ~point_bol =
method byte_offset = byte.Lexing.pos_cnum
method to_string ?(offsets=true) mode =
let offset = self#offset mode in
let horizontal, value =
if offsets then "character", offset else "column", offset + 1
in sprintf "File \"%s\", line %i, %s %i"
self#file self#line horizontal value
method compact ?(offsets=true) mode =
method to_string ?(file=true) ?(offsets=true) mode =
if self#is_ghost then "ghost"
else
let offset = self#offset mode in
sprintf "%s:%i:%i"
self#file self#line (if offsets then offset else offset + 1)
let horizontal, value =
if offsets then
"character", offset
else "column", offset + 1 in
if file && self#file <> "" then
sprintf "File \"%s\", line %i, %s %i"
self#file self#line horizontal value
else sprintf "Line %i, %s %i"
self#line horizontal value
method anonymous ?(offsets=true) mode =
if self#is_ghost then "ghost"
else sprintf "%i:%i" self#line
(if offsets then self#offset mode else self#column mode)
method compact ?(file=true) ?(offsets=true) mode =
if self#is_ghost then "ghost"
else
let horizontal =
if offsets then self#offset mode
else self#column mode in
if file && self#file <> "" then
sprintf "%s:%i:%i" self#file self#line horizontal
else
sprintf "%i:%i" self#line horizontal
end
let from_byte byte =
@ -126,7 +136,9 @@ let from_byte byte =
let ghost = make ~byte:Lexing.dummy_pos ~point_num:(-1) ~point_bol:(-1)
let min = make ~byte:Lexing.dummy_pos ~point_num:0 ~point_bol:0
let min file =
let pos = make ~byte:Lexing.dummy_pos ~point_num:0 ~point_bol:0
in pos#set_file file
(* Comparisons *)

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

@ -58,23 +58,36 @@
{li The call [pos#byte_offset] is the offset of the position
[pos] since the begininng of the file, counted in bytes.}}
*)
type t = <
type invalid_pos = [
`Invalid_line
| `Invalid_offset
]
type invalid_line = `Invalid_line
type invalid_offset = `Invalid_offset
type invalid_nl = `Invalid_newline
type t = private <
(* Payload *)
byte : Lexing.position;
point_num : int;
point_bol : int;
file : string;
line : int;
point_num : int; (* point_num >= point_bol *)
point_bol : int; (* point_bol >= 0 *)
file : string; (* May be empty *)
line : int; (* line > 0 *)
(* Setters *)
set_file : string -> t;
set_line : int -> t;
set_offset : int -> t;
set : file:string -> line:int -> offset:int -> t;
set_line : int -> (t, invalid_line) Stdlib.result;
set_offset : int -> (t, invalid_offset) Stdlib.result;
new_line : string -> t;
set : ?file:string -> line:int -> offset:int ->
(t, invalid_pos) Stdlib.result;
(* String must be "\n" or "\c\r" *)
new_line : string -> (t, invalid_newline) Stdlib.result
add_nl : t;
shift_bytes : int -> t;
@ -93,9 +106,10 @@ type t = <
(* Conversions to [string] *)
to_string : ?offsets:bool -> [`Byte | `Point] -> string;
compact : ?offsets:bool -> [`Byte | `Point] -> string;
anonymous : ?offsets:bool -> [`Byte | `Point] -> string
to_string :
?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
compact :
?file:bool -> ?offsets:bool -> [`Byte | `Point] -> string;
>
(** A shorthand after an [open Pos].
@ -104,18 +118,22 @@ type pos = t
(** {1 Constructors} *)
val make : byte:Lexing.position -> point_num:int -> point_bol:int -> t
val from_byte : Lexing.position -> t
val make :
byte:Lexing.position -> point_num:int -> point_bol:int ->
(t, invalid_pos) Stdlin.result
val from_byte :
Lexing.position -> (t, invalid_pos) Stdlib.result
(** {1 Special positions} *)
(** The value [ghost] is the same as {! Lexing.dummy_pos}.
(** The value [ghost] based on the same as {! Lexing.dummy_pos}.
*)
val ghost : t
(** Lexing convention: line [1], offsets to [0] and file to [""].
(** Lexing convention: line [1], offset to [0].
*)
val min : t
val min : file:string -> t
(** {1 Comparisons} *)

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

@ -101,8 +101,8 @@ let make ~(start: Pos.t) ~(stop: Pos.t) =
if start#is_ghost || stop#is_ghost then "ghost"
else
let prefix = if file then start#file ^ ":" else ""
and start_str = start#anonymous ~offsets mode
and stop_str = stop#anonymous ~offsets mode in
and start_str = start#compact ~file:false ~offsets mode
and stop_str = stop#compact ~file:false ~offsets mode in
if start#file = stop#file then
if start#line = stop#line then
sprintf "%s%s-%i" prefix start_str

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

@ -54,9 +54,9 @@
{li The method [compact] has the same signature as and calling
convention as [to_string], except that the resulting string
is more compact.}}
is shorter (usually for debugging or tracing).}}
*)
type t = <
type t = private <
start : Pos.t;
stop : Pos.t;
@ -86,9 +86,9 @@ type t = <
*)
type region = t
(** The type ['a reg] enables the concept of something of type ['a] to
(** The type ['a reg] enables the concept of some value of type ['a] to
be related to a region in a source file.
*)
*)
type 'a reg = {region: t; value: 'a}
(* {1 Constructors} *)